diff options
| author | julie <julielangou@users.noreply.github.com> | 2008-12-16 17:06:58 +0000 |
|---|---|---|
| committer | julie <julielangou@users.noreply.github.com> | 2008-12-16 17:06:58 +0000 |
| commit | ff981f106bde4ce6a74aa4f4a572c943f5a395b2 (patch) | |
| tree | a386cad907bcaefd6893535c31d67ec9468e693e /SRC | |
| parent | e58b61578b55644f6391f3333262b72c1dc88437 (diff) | |
| download | lapack-ff981f106bde4ce6a74aa4f4a572c943f5a395b2.tar.gz lapack-ff981f106bde4ce6a74aa4f4a572c943f5a395b2.tar.bz2 lapack-ff981f106bde4ce6a74aa4f4a572c943f5a395b2.zip | |
Diffstat (limited to 'SRC')
1588 files changed, 83172 insertions, 4520 deletions
diff --git a/SRC/Makefile b/SRC/Makefile index 2d79fcc2..d610f14e 100644 --- a/SRC/Makefile +++ b/SRC/Makefile @@ -4,13 +4,23 @@ include ../make.inc # This is the makefile to create a library for LAPACK. # The files are organized as follows: # ALLAUX -- Auxiliary routines called from all precisions +# ALLXAUX -- Auxiliary routines called from all precisions but +# only from routines using extra precision. # SCLAUX -- Auxiliary routines called from both REAL and COMPLEX # DZLAUX -- Auxiliary routines called from both DOUBLE PRECISION # and COMPLEX*16 # SLASRC -- Single precision real LAPACK routines +# SXLASRC -- Single precision real LAPACK routines using extra +# precision. # CLASRC -- Single precision complex LAPACK routines +# CXLASRC -- Single precision complex LAPACK routines using extra +# precision. # DLASRC -- Double precision real LAPACK routines +# DXLASRC -- Double precision real LAPACK routines using extra +# precision. # ZLASRC -- Double precision complex LAPACK routines +# ZXLASRC -- Double precision complex LAPACK routines using extra +# precision. # # The library can be set up to include routines for any combination # of the four precisions. To create or add to the library, enter make @@ -37,9 +47,12 @@ include ../make.inc # installation guide, LAPACK Working Note 41, for instructions. # ####################################################################### - + ALLAUX = ilaenv.o ieeeck.o lsamen.o xerbla.o xerbla_array.o iparmq.o \ - ila_len_trim.o ../INSTALL/ilaver.o ../INSTALL/lsame.o + ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o \ + ../INSTALL/ilaver.o ../INSTALL/lsame.o + +ALLXAUX = SCLAUX = \ sbdsdc.o \ @@ -53,7 +66,7 @@ SCLAUX = \ slartg.o slaruv.o slas2.o slascl.o \ slasd0.o slasd1.o slasd2.o slasd3.o slasd4.o slasd5.o slasd6.o \ slasd7.o slasd8.o slasda.o slasdq.o slasdt.o \ - slaset.o slasq1.o slasq2.o slasq3.o slazq3.o slasq4.o slazq4.o slasq5.o slasq6.o \ + slaset.o slasq1.o slasq2.o slasq3.o slasq4.o slasq5.o slasq6.o \ slasr.o slasrt.o slassq.o slasv2.o spttrf.o sstebz.o sstedc.o \ ssteqr.o ssterf.o slaisnan.o sisnan.o \ ../INSTALL/slamch.o ../INSTALL/second_$(TIMER).o @@ -70,7 +83,7 @@ DZLAUX = \ dlartg.o dlaruv.o dlas2.o dlascl.o \ dlasd0.o dlasd1.o dlasd2.o dlasd3.o dlasd4.o dlasd5.o dlasd6.o \ dlasd7.o dlasd8.o dlasda.o dlasdq.o dlasdt.o \ - dlaset.o dlasq1.o dlasq2.o dlasq3.o dlazq3.o dlasq4.o dlazq4.o dlasq5.o dlasq6.o \ + dlaset.o dlasq1.o dlasq2.o dlasq3.o dlasq4.o dlasq5.o dlasq6.o \ dlasr.o dlasrt.o dlassq.o dlasv2.o dpttrf.o dstebz.o dstedc.o \ dsteqr.o dsterf.o dlaisnan.o disnan.o \ ../INSTALL/dlamch.o ../INSTALL/dsecnd_$(TIMER).o @@ -108,7 +121,8 @@ SLASRC = \ sormr3.o sormrq.o sormrz.o sormtr.o spbcon.o spbequ.o spbrfs.o \ spbstf.o spbsv.o spbsvx.o \ spbtf2.o spbtrf.o spbtrs.o spocon.o spoequ.o sporfs.o sposv.o \ - sposvx.o spotf2.o spotrf.o spotri.o spotrs.o sppcon.o sppequ.o \ + sposvx.o spotf2.o spotrf.o spotri.o spotrs.o spstrf.o spstf2.o \ + sppcon.o sppequ.o \ spprfs.o sppsv.o sppsvx.o spptrf.o spptri.o spptrs.o sptcon.o \ spteqr.o sptrfs.o sptsv.o sptsvx.o spttrs.o sptts2.o srscl.o \ ssbev.o ssbevd.o ssbevx.o ssbgst.o ssbgv.o ssbgvd.o ssbgvx.o \ @@ -122,7 +136,19 @@ SLASRC = \ stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \ stptrs.o \ strcon.o strevc.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \ - strti2.o strtri.o strtrs.o stzrqf.o stzrzf.o sstemr.o + strti2.o strtri.o strtrs.o stzrqf.o stzrzf.o sstemr.o \ + slansf.o spftrf.o spftri.o spftrs.o ssfrk.o stfsm.o stftri.o stfttp.o \ + stfttr.o stpttf.o stpttr.o strttf.o strttp.o \ + sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \ + sgeequb.o ssyequb.o spoequb.o sgbequb.o + +SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \ + sla_gercond.o sla_rpvgrw.o ssysvxx.o ssyrfsx.o \ + sla_syrfsx_extended.o sla_syamv.o sla_syrcond.o sla_syrpvgrw.o \ + sposvxx.o sporfsx.o sla_porfsx_extended.o sla_porcond.o \ + sla_porpvgrw.o sgbsvxx.o sgbrfsx.o sla_gbrfsx_extended.o \ + sla_gbamv.o sla_gbrcond.o sla_gbrpvgrw.o sla_lin_berr.o slarscl2.o \ + slascl2.o sla_wwaddw.o CLASRC = \ cbdsqr.o cgbbrd.o cgbcon.o cgbequ.o cgbrfs.o cgbsv.o cgbsvx.o \ @@ -162,8 +188,8 @@ CLASRC = \ claswp.o clasyf.o clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ clatzm.o clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \ - cposv.o cposvx.o cpotf2.o cpotrf.o cpotri.o cpotrs.o cppcon.o \ - cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \ + cposv.o cposvx.o cpotf2.o cpotrf.o cpotri.o cpotrs.o cpstrf.o cpstf2.o \ + cppcon.o cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \ cptcon.o cpteqr.o cptrfs.o cptsv.o cptsvx.o cpttrf.o cpttrs.o cptts2.o \ crot.o cspcon.o cspmv.o cspr.o csprfs.o cspsv.o \ cspsvx.o csptrf.o csptri.o csptrs.o csrscl.o cstedc.o \ @@ -177,7 +203,22 @@ CLASRC = \ cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \ cungrq.o cungtr.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o \ cunmlq.o cunmql.o cunmqr.o cunmr2.o cunmr3.o cunmrq.o cunmrz.o \ - cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o + cunmtr.o cupgtr.o cupmtr.o icmax1.o scsum1.o cstemr.o \ + chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \ + ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \ + cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o + +CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \ + cla_gercond_c.o cla_gercond_x.o cla_rpvgrw.o \ + csysvxx.o csyrfsx.o cla_syrfsx_extended.o cla_syamv.o \ + cla_syrcond_c.o cla_syrcond_x.o cla_syrpvgrw.o \ + cposvxx.o cporfsx.o cla_porfsx_extended.o \ + cla_porcond_c.o cla_porcond_x.o cla_porpvgrw.o \ + cgbsvxx.o cgbrfsx.o cla_gbrfsx_extended.o cla_gbamv.o \ + cla_gbrcond_c.o cla_gbrcond_x.o cla_gbrpvgrw.o \ + chesvxx.o cherfsx.o cla_herfsx_extended.o cla_heamv.o \ + cla_hercond_c.o cla_hercond_x.o cla_herpvgrw.o \ + cla_lin_berr.o clarscl2.o clascl2.o cla_wwaddw.o DLASRC = \ dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o \ @@ -212,7 +253,8 @@ DLASRC = \ dormr3.o dormrq.o dormrz.o dormtr.o dpbcon.o dpbequ.o dpbrfs.o \ dpbstf.o dpbsv.o dpbsvx.o \ dpbtf2.o dpbtrf.o dpbtrs.o dpocon.o dpoequ.o dporfs.o dposv.o \ - dposvx.o dpotf2.o dpotrf.o dpotri.o dpotrs.o dppcon.o dppequ.o \ + dposvx.o dpotf2.o dpotrf.o dpotri.o dpotrs.o dpstrf.o dpstf2.o \ + dppcon.o dppequ.o \ dpprfs.o dppsv.o dppsvx.o dpptrf.o dpptri.o dpptrs.o dptcon.o \ dpteqr.o dptrfs.o dptsv.o dptsvx.o dpttrs.o dptts2.o drscl.o \ dsbev.o dsbevd.o dsbevx.o dsbgst.o dsbgv.o dsbgvd.o dsbgvx.o \ @@ -228,7 +270,19 @@ DLASRC = \ dtptrs.o \ dtrcon.o dtrevc.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \ dtrti2.o dtrtri.o dtrtrs.o dtzrqf.o dtzrzf.o dstemr.o \ - dsgesv.o dlag2s.o slag2d.o + dsgesv.o dsposv.o dlag2s.o slag2d.o dlat2s.o \ + dlansf.o dpftrf.o dpftri.o dpftrs.o dsfrk.o dtfsm.o dtftri.o dtfttp.o \ + dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \ + dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \ + dgeequb.o dsyequb.o dpoequb.o dgbequb.o + +DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \ + dla_gercond.o dla_rpvgrw.o dsysvxx.o dsyrfsx.o \ + dla_syrfsx_extended.o dla_syamv.o dla_syrcond.o dla_syrpvgrw.o \ + dposvxx.o dporfsx.o dla_porfsx_extended.o dla_porcond.o \ + dla_porpvgrw.o dgbsvxx.o dgbrfsx.o dla_gbrfsx_extended.o \ + dla_gbamv.o dla_gbrcond.o dla_gbrpvgrw.o dla_lin_berr.o dlarscl2.o \ + dlascl2.o dla_wwaddw.o ZLASRC = \ zbdsqr.o zgbbrd.o zgbcon.o zgbequ.o zgbrfs.o zgbsv.o zgbsvx.o \ @@ -271,8 +325,8 @@ ZLASRC = \ zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlatzm.o zlauu2.o \ zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \ - zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zppcon.o \ - zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \ + zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \ + zppcon.o zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \ zptcon.o zpteqr.o zptrfs.o zptsv.o zptsvx.o zpttrf.o zpttrs.o zptts2.o \ zrot.o zspcon.o zspmv.o zspr.o zsprfs.o zspsv.o \ zspsvx.o zsptrf.o zsptri.o zsptrs.o zdrscl.o zstedc.o \ @@ -288,15 +342,32 @@ ZLASRC = \ zunmlq.o zunmql.o zunmqr.o zunmr2.o zunmr3.o zunmrq.o zunmrz.o \ zunmtr.o zupgtr.o \ zupmtr.o izmax1.o dzsum1.o zstemr.o \ - zcgesv.o zlag2c.o clag2z.o + zcgesv.o zcposv.o zlag2c.o clag2z.o zlat2c.o \ + zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \ + ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \ + zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o + +ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \ + zla_gercond_c.o zla_gercond_x.o zla_rpvgrw.o zsysvxx.o zsyrfsx.o \ + zla_syrfsx_extended.o zla_syamv.o zla_syrcond_c.o zla_syrcond_x.o \ + zla_syrpvgrw.o zposvxx.o zporfsx.o zla_porfsx_extended.o \ + zla_porcond_c.o zla_porcond_x.o zla_porpvgrw.o zgbsvxx.o zgbrfsx.o \ + zla_gbrfsx_extended.o zla_gbamv.o zla_gbrcond_c.o zla_gbrcond_x.o \ + zla_gbrpvgrw.o zhesvxx.o zherfsx.o zla_herfsx_extended.o \ + zla_heamv.o zla_hercond_c.o zla_hercond_x.o zla_herpvgrw.o \ + zla_lin_berr.o zlarscl2.o zlascl2.o zla_wwaddw.o all: ../$(LAPACKLIB) +ifdef USEXBLAS +ALLXOBJ=$(SXLASRC) $(DXLASRC) $(CXLASRC) $(ZXLASRC) $(ALLXAUX) +endif + ALLOBJ=$(SLASRC) $(DLASRC) $(CLASRC) $(ZLASRC) $(SCLAUX) $(DZLAUX) \ $(ALLAUX) -../$(LAPACKLIB): $(ALLOBJ) - $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ) +../$(LAPACKLIB): $(ALLOBJ) $(ALLXOBJ) + $(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ) $(ALLXOBJ) $(RANLIB) $@ single: $(SLASRC) $(ALLAUX) $(SCLAUX) @@ -326,6 +397,13 @@ $(SLASRC): $(FRC) $(CLASRC): $(FRC) $(DLASRC): $(FRC) $(ZLASRC): $(FRC) +ifdef USEXBLAS +$(ALLXAUX): $(FRC) +$(SXLASRC): $(FRC) +$(CXLASRC): $(FRC) +$(DXLASRC): $(FRC) +$(ZXLASRC): $(FRC) +endif FRC: @FRC=$(FRC) @@ -338,4 +416,8 @@ clean: slaruv.o: slaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ dlaruv.o: dlaruv.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ +sla_wwaddw.o: sla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ +dla_wwaddw.o: dla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ +cla_wwaddw.o: cla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ +zla_wwaddw.o: zla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@ diff --git a/SRC/cbdsqr.f b/SRC/cbdsqr.f index cc03e132..2e4b77bb 100644 --- a/SRC/cbdsqr.f +++ b/SRC/cbdsqr.f @@ -1,7 +1,7 @@ SUBROUTINE CBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbbrd.f b/SRC/cgbbrd.f index fc57ee9d..1d97dd93 100644 --- a/SRC/cgbbrd.f +++ b/SRC/cgbbrd.f @@ -1,7 +1,7 @@ SUBROUTINE CGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbcon.f b/SRC/cgbcon.f index c171763c..58f80d07 100644 --- a/SRC/cgbcon.f +++ b/SRC/cgbcon.f @@ -1,7 +1,7 @@ SUBROUTINE CGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbequ.f b/SRC/cgbequ.f index 4b6aae82..d2f49215 100644 --- a/SRC/cgbequ.f +++ b/SRC/cgbequ.f @@ -1,7 +1,7 @@ SUBROUTINE CGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbequb.f b/SRC/cgbequb.f new file mode 100644 index 00000000..e447ce42 --- /dev/null +++ b/SRC/cgbequb.f @@ -0,0 +1,270 @@ + SUBROUTINE CGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + REAL AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + REAL C( * ), R( * ) + COMPLEX AB( LDAB, * ) +* .. +* +* Purpose +* ======= +* +* CGBEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from CGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* LDAB (input) INTEGER +* The leading dimension of the array A. LDAB >= max(1,M). +* +* R (output) REAL array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) REAL array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) REAL +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) REAL +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + REAL BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, + $ LOGRDX + COMPLEX ZDUM +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGBEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = SLAMCH( 'B' ) + LOGRDX = LOG(RADIX) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + KD = KU + 1 + DO 30 J = 1, N + DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + R( I ) = MAX( R( I ), CABS1( AB( KD+I-J, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + C( J ) = MAX( C( J ), CABS1( AB( KD+I-J, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of CGBEQUB +* + END diff --git a/SRC/cgbrfs.f b/SRC/cgbrfs.f index d15ca585..719c1971 100644 --- a/SRC/cgbrfs.f +++ b/SRC/cgbrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbrfsx.f b/SRC/cgbrfsx.f new file mode 100644 index 00000000..df739be9 --- /dev/null +++ b/SRC/cgbrfsx.f @@ -0,0 +1,624 @@ + SUBROUTINE CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, + $ NPARAMS, N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* CGBRFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* The original band matrix A, stored in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) +* Details of the LU factorization of the band matrix A, as +* computed by DGBTRF. U is stored as an upper triangular band +* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +* the multipliers used during the factorization are stored in +* rows KL+KU+2 to 2*KL+KU+1. +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from SGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) REAL array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) REAL array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN, IGNORE_CWISE + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE, N_NORMS, + $ ITHRESH + REAL ANORM, RCOND_TMP, ILLRCOND_THRESH, ERR_LBND, + $ CWISE_WRONG, RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CGBCON, CLA_GBRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C + REAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGBRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = CLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) + CALL CGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, + $ WORK, RWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + IF ( NOTRAN ) THEN + CALL CLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + ELSE + CALL CLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, C, .TRUE., INFO, WORK, RWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, R, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, C, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, + $ AFB, LDAFB, IPIV, X( 1, J ), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of CGBRFSX +* + END diff --git a/SRC/cgbsv.f b/SRC/cgbsv.f index 6168f2fb..72a204dc 100644 --- a/SRC/cgbsv.f +++ b/SRC/cgbsv.f @@ -1,6 +1,6 @@ SUBROUTINE CGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbsvx.f b/SRC/cgbsvx.f index c9024e96..89e086c2 100644 --- a/SRC/cgbsvx.f +++ b/SRC/cgbsvx.f @@ -2,7 +2,7 @@ $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbsvxx.f b/SRC/cgbsvxx.f new file mode 100644 index 00000000..f038cc26 --- /dev/null +++ b/SRC/cgbsvxx.f @@ -0,0 +1,658 @@ + SUBROUTINE CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, + $ RCOND, RPVGRW, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* CGBSVXX uses the LU factorization to compute the solution to a +* complex system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. CGBSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* CGBSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* CGBSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what CGBSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose = Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input/output) REAL array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* If FACT = 'F' and EQUED is not 'N', then AB must have been +* equilibrated by the scaling factors in R and/or C. AB is not +* modified if FACT = 'F' or 'N', or if FACT = 'E' and +* EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input or output) REAL array, dimension (LDAFB,N) +* If FACT = 'F', then AFB is an input argument and on entry +* contains details of the LU factorization of the band matrix +* A, as computed by CGBTRF. U is stored as an upper triangular +* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +* and the multipliers used during the factorization are stored +* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is +* the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by SGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) REAL array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) REAL array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In SGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, I, J, KL, KU + REAL AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, CLA_GBRPVGRW + LOGICAL LSAME + REAL SLAMCH, CLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL CGBEQUB, CGBTRF, CGBTRS, CLACPY, CLAQGB, + $ XERBLA, CLASCL2, CGBRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in CGBRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until SGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -12 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -13 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -14 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGBSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL CGBEQUB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL CLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL CLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL CLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + DO 40, J = 1, N + DO 30, I = KL+1, 2*KL+KU+1 + AFB( I, J ) = AB( I-KL, J ) + 30 CONTINUE + 40 CONTINUE + CALL CGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = CLA_GBRPVGRW( N, KL, KU, INFO, AB, LDAB, AFB, + $ LDAFB ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = CLA_GBRPVGRW( N, KL, KU, N, AB, LDAB, AFB, LDAFB ) +* +* Compute the solution matrix X. +* + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL CGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL CGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) + +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL CLASCL2( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL CLASCL2( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of CGBSVXX +* + END diff --git a/SRC/cgbtf2.f b/SRC/cgbtf2.f index cb40ef74..8fa9b2a2 100644 --- a/SRC/cgbtf2.f +++ b/SRC/cgbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE CGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbtrf.f b/SRC/cgbtrf.f index 88758b97..968ab777 100644 --- a/SRC/cgbtrf.f +++ b/SRC/cgbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE CGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgbtrs.f b/SRC/cgbtrs.f index 15d6b80e..97cd84bb 100644 --- a/SRC/cgbtrs.f +++ b/SRC/cgbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE CGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgebak.f b/SRC/cgebak.f index 45e88aa8..2f8c8c5d 100644 --- a/SRC/cgebak.f +++ b/SRC/cgebak.f @@ -1,7 +1,7 @@ SUBROUTINE CGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgebal.f b/SRC/cgebal.f index 12394eac..4fd1d092 100644 --- a/SRC/cgebal.f +++ b/SRC/cgebal.f @@ -1,6 +1,6 @@ SUBROUTINE CGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgebd2.f b/SRC/cgebd2.f index 8317128d..1d4030dc 100644 --- a/SRC/cgebd2.f +++ b/SRC/cgebd2.f @@ -1,6 +1,6 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgebrd.f b/SRC/cgebrd.f index 4ee39f66..27392c19 100644 --- a/SRC/cgebrd.f +++ b/SRC/cgebrd.f @@ -1,7 +1,7 @@ SUBROUTINE CGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgecon.f b/SRC/cgecon.f index a4673e26..2f789732 100644 --- a/SRC/cgecon.f +++ b/SRC/cgecon.f @@ -1,7 +1,7 @@ SUBROUTINE CGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeequ.f b/SRC/cgeequ.f index 93a1283c..5895f132 100644 --- a/SRC/cgeequ.f +++ b/SRC/cgeequ.f @@ -1,7 +1,7 @@ SUBROUTINE CGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeequb.f b/SRC/cgeequb.f new file mode 100644 index 00000000..b8dd2dd5 --- /dev/null +++ b/SRC/cgeequb.f @@ -0,0 +1,256 @@ + SUBROUTINE CGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + REAL AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + REAL C( * ), R( * ) + COMPLEX A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* CGEEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from CGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The M-by-N matrix whose equilibration factors are +* to be computed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* R (output) REAL array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) REAL array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) REAL +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) REAL +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX + COMPLEX ZDUM +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGEEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = SLAMCH( 'B' ) + LOGRDX = LOG( RADIX ) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + DO 30 J = 1, N + DO 20 I = 1, M + R( I ) = MAX( R( I ), CABS1( A( I, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG(R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = 1, M + C( J ) = MAX( C( J ), CABS1( A( I, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of CGEEQUB +* + END diff --git a/SRC/cgees.f b/SRC/cgees.f index 648de4ff..0be4146a 100644 --- a/SRC/cgees.f +++ b/SRC/cgees.f @@ -1,7 +1,7 @@ SUBROUTINE CGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, $ LDVS, WORK, LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeesx.f b/SRC/cgeesx.f index c0f1f7d0..2ccb03a9 100644 --- a/SRC/cgeesx.f +++ b/SRC/cgeesx.f @@ -2,7 +2,7 @@ $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeev.f b/SRC/cgeev.f index 8a493c83..536e5620 100644 --- a/SRC/cgeev.f +++ b/SRC/cgeev.f @@ -1,7 +1,7 @@ SUBROUTINE CGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeevx.f b/SRC/cgeevx.f index 7bcbd323..d07efc94 100644 --- a/SRC/cgeevx.f +++ b/SRC/cgeevx.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, $ RCONDV, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgegs.f b/SRC/cgegs.f index 754ee7f9..16a5125b 100644 --- a/SRC/cgegs.f +++ b/SRC/cgegs.f @@ -2,7 +2,7 @@ $ VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgegv.f b/SRC/cgegv.f index dab2b022..202bcc55 100644 --- a/SRC/cgegv.f +++ b/SRC/cgegv.f @@ -1,7 +1,7 @@ SUBROUTINE CGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgehd2.f b/SRC/cgehd2.f index c3cb2b71..0650827b 100644 --- a/SRC/cgehd2.f +++ b/SRC/cgehd2.f @@ -1,6 +1,6 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgehrd.f b/SRC/cgehrd.f index 48c48b48..055db08d 100644 --- a/SRC/cgehrd.f +++ b/SRC/cgehrd.f @@ -1,6 +1,6 @@ SUBROUTINE CGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgelq2.f b/SRC/cgelq2.f index 46047291..e94d5e69 100644 --- a/SRC/cgelq2.f +++ b/SRC/cgelq2.f @@ -1,6 +1,6 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgelqf.f b/SRC/cgelqf.f index 7f6bd73e..6c9c66e4 100644 --- a/SRC/cgelqf.f +++ b/SRC/cgelqf.f @@ -1,6 +1,6 @@ SUBROUTINE CGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgels.f b/SRC/cgels.f index 30f4d5c0..4055e556 100644 --- a/SRC/cgels.f +++ b/SRC/cgels.f @@ -1,7 +1,7 @@ SUBROUTINE CGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgelsd.f b/SRC/cgelsd.f index 073c79e9..900bd128 100644 --- a/SRC/cgelsd.f +++ b/SRC/cgelsd.f @@ -1,7 +1,7 @@ SUBROUTINE CGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgelss.f b/SRC/cgelss.f index 005f87d5..f6f08b51 100644 --- a/SRC/cgelss.f +++ b/SRC/cgelss.f @@ -1,7 +1,7 @@ SUBROUTINE CGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgelsx.f b/SRC/cgelsx.f index f809ff95..293210da 100644 --- a/SRC/cgelsx.f +++ b/SRC/cgelsx.f @@ -1,7 +1,7 @@ SUBROUTINE CGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgelsy.f b/SRC/cgelsy.f index 77ae7fa8..8bd49205 100644 --- a/SRC/cgelsy.f +++ b/SRC/cgelsy.f @@ -1,7 +1,7 @@ SUBROUTINE CGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeql2.f b/SRC/cgeql2.f index 57c517a7..b16506f0 100644 --- a/SRC/cgeql2.f +++ b/SRC/cgeql2.f @@ -1,6 +1,6 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeqlf.f b/SRC/cgeqlf.f index 11c131df..e5c2d17a 100644 --- a/SRC/cgeqlf.f +++ b/SRC/cgeqlf.f @@ -1,6 +1,6 @@ SUBROUTINE CGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeqp3.f b/SRC/cgeqp3.f index 548123e1..5df5e6f8 100644 --- a/SRC/cgeqp3.f +++ b/SRC/cgeqp3.f @@ -1,7 +1,7 @@ SUBROUTINE CGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeqpf.f b/SRC/cgeqpf.f index 40fa83d8..f9b58504 100644 --- a/SRC/cgeqpf.f +++ b/SRC/cgeqpf.f @@ -1,6 +1,6 @@ SUBROUTINE CGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * -* -- LAPACK deprecated driver routine (version 3.1) -- +* -- LAPACK deprecated driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeqr2.f b/SRC/cgeqr2.f index df7c44a0..4860d21d 100644 --- a/SRC/cgeqr2.f +++ b/SRC/cgeqr2.f @@ -1,6 +1,6 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgeqrf.f b/SRC/cgeqrf.f index 6cd3282a..76c0e6ab 100644 --- a/SRC/cgeqrf.f +++ b/SRC/cgeqrf.f @@ -1,6 +1,6 @@ SUBROUTINE CGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgerfs.f b/SRC/cgerfs.f index f958f9d5..b0c7813d 100644 --- a/SRC/cgerfs.f +++ b/SRC/cgerfs.f @@ -1,7 +1,7 @@ SUBROUTINE CGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgerfsx.f b/SRC/cgerfsx.f new file mode 100644 index 00000000..3e1288f1 --- /dev/null +++ b/SRC/cgerfsx.f @@ -0,0 +1,606 @@ + SUBROUTINE CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ), WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* CGERFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The original N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX array, dimension (LDAF,N) +* The factors L and U from the factorization A = P*L*U +* as computed by CGETRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from CGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) COMPLEX array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by CGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CGECON, CLA_GERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, CLANGE, CLA_GERCOND_X, CLA_GERCOND_C + REAL SLAMCH, CLANGE, CLA_GERCOND_X, CLA_GERCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS(LA_LINRX_ITHRESH_I) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = CLANGE( NORM, N, N, A, LDA, WORK ) + CALL CGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + IF ( NOTRAN ) THEN + CALL CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + ELSE + CALL CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ C, .TRUE., INFO, WORK, RWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ R, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ C, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF (ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, + $ IPIV, X(1,J), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of CGERFSX +* + END diff --git a/SRC/cgerq2.f b/SRC/cgerq2.f index 0ac136f2..fd23f31f 100644 --- a/SRC/cgerq2.f +++ b/SRC/cgerq2.f @@ -1,6 +1,6 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgerqf.f b/SRC/cgerqf.f index a507f820..7d8dedb7 100644 --- a/SRC/cgerqf.f +++ b/SRC/cgerqf.f @@ -1,6 +1,6 @@ SUBROUTINE CGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgesc2.f b/SRC/cgesc2.f index a70cbe30..7b030fc8 100644 --- a/SRC/cgesc2.f +++ b/SRC/cgesc2.f @@ -1,6 +1,6 @@ SUBROUTINE CGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgesdd.f b/SRC/cgesdd.f index 6bbf697f..89e06f74 100644 --- a/SRC/cgesdd.f +++ b/SRC/cgesdd.f @@ -1,7 +1,7 @@ SUBROUTINE CGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * 8-15-00: Improve consistency of WS calculations (eca) diff --git a/SRC/cgesv.f b/SRC/cgesv.f index 7b362dd3..5e7a1175 100644 --- a/SRC/cgesv.f +++ b/SRC/cgesv.f @@ -1,6 +1,6 @@ SUBROUTINE CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgesvd.f b/SRC/cgesvd.f index 9ba709f9..8ab58d00 100644 --- a/SRC/cgesvd.f +++ b/SRC/cgesvd.f @@ -1,7 +1,7 @@ SUBROUTINE CGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgesvx.f b/SRC/cgesvx.f index 0f435079..a6255766 100644 --- a/SRC/cgesvx.f +++ b/SRC/cgesvx.f @@ -2,7 +2,7 @@ $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgesvxx.f b/SRC/cgesvxx.f new file mode 100644 index 00000000..d7c1bd2b --- /dev/null +++ b/SRC/cgesvxx.f @@ -0,0 +1,633 @@ + SUBROUTINE CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* CGESVXX uses the LU factorization to compute the solution to a +* complex system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. CGESVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* CGESVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* CGESVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what CGESVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX array, dimension (LDA,N) +* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is +* not 'N', then A must have been equilibrated by the scaling +* factors in R and/or C. A is not modified if FACT = 'F' or +* 'N', or if FACT = 'E' and EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the factors L and U from the factorization +* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then +* AF is the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by CGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) COMPLEX array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In CGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) COMPLEX array, dimension (2*N) +* +* RWORK (workspace) REAL array, dimension (3*N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, CLA_RPVGRW + LOGICAL LSAME + REAL SLAMCH, CLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL CGEEQUB, CGETRF, CGETRS, CLACPY, CLAQGE, + $ XERBLA, CLASCL2, CGERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in CGERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until CGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL CGEEQUB( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL CLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL CLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL CLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL CLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL CGETRF( N, N, AF, LDAF, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = CLA_RPVGRW( N, INFO, A, LDA, AF, LDAF ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = CLA_RPVGRW( N, N, A, LDA, AF, LDAF ) +* +* Compute the solution matrix X. +* + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL CGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL CGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL CLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL CLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of CGESVXX +* + END diff --git a/SRC/cgetc2.f b/SRC/cgetc2.f index ac7608f5..2bb66697 100644 --- a/SRC/cgetc2.f +++ b/SRC/cgetc2.f @@ -1,6 +1,6 @@ SUBROUTINE CGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgetf2.f b/SRC/cgetf2.f index 48b0d794..6b36e77a 100644 --- a/SRC/cgetf2.f +++ b/SRC/cgetf2.f @@ -1,6 +1,6 @@ SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgetrf.f b/SRC/cgetrf.f index 9c6fd5ad..0368fce6 100644 --- a/SRC/cgetrf.f +++ b/SRC/cgetrf.f @@ -1,6 +1,6 @@ SUBROUTINE CGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgetri.f b/SRC/cgetri.f index 86b3ad32..21d79119 100644 --- a/SRC/cgetri.f +++ b/SRC/cgetri.f @@ -1,6 +1,6 @@ SUBROUTINE CGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgetrs.f b/SRC/cgetrs.f index 0b58ad7a..fc98256c 100644 --- a/SRC/cgetrs.f +++ b/SRC/cgetrs.f @@ -1,6 +1,6 @@ SUBROUTINE CGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggbak.f b/SRC/cggbak.f index c0f6a8bf..0f15eeef 100644 --- a/SRC/cggbak.f +++ b/SRC/cggbak.f @@ -1,7 +1,7 @@ SUBROUTINE CGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggbal.f b/SRC/cggbal.f index 42007d3e..c64cae30 100644 --- a/SRC/cggbal.f +++ b/SRC/cggbal.f @@ -1,7 +1,7 @@ SUBROUTINE CGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgges.f b/SRC/cgges.f index b6898b83..b8b5ff2e 100644 --- a/SRC/cgges.f +++ b/SRC/cgges.f @@ -2,7 +2,7 @@ $ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggesx.f b/SRC/cggesx.f index d951695c..ba1f292a 100644 --- a/SRC/cggesx.f +++ b/SRC/cggesx.f @@ -3,7 +3,7 @@ $ LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggev.f b/SRC/cggev.f index e6403e85..d8408d9c 100644 --- a/SRC/cggev.f +++ b/SRC/cggev.f @@ -1,7 +1,7 @@ SUBROUTINE CGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggevx.f b/SRC/cggevx.f index 63d9ebbd..4f9fcc80 100644 --- a/SRC/cggevx.f +++ b/SRC/cggevx.f @@ -3,7 +3,7 @@ $ LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, $ WORK, LWORK, RWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggglm.f b/SRC/cggglm.f index 413b8778..22adb156 100644 --- a/SRC/cggglm.f +++ b/SRC/cggglm.f @@ -1,7 +1,7 @@ SUBROUTINE CGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgghrd.f b/SRC/cgghrd.f index 9bc4ca18..961350f0 100644 --- a/SRC/cgghrd.f +++ b/SRC/cgghrd.f @@ -1,7 +1,7 @@ SUBROUTINE CGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgglse.f b/SRC/cgglse.f index 0a8cc855..4c2eed7f 100644 --- a/SRC/cgglse.f +++ b/SRC/cgglse.f @@ -1,7 +1,7 @@ SUBROUTINE CGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggqrf.f b/SRC/cggqrf.f index 380b8537..c5732ce7 100644 --- a/SRC/cggqrf.f +++ b/SRC/cggqrf.f @@ -1,7 +1,7 @@ SUBROUTINE CGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggrqf.f b/SRC/cggrqf.f index 9530d65f..849e0e6d 100644 --- a/SRC/cggrqf.f +++ b/SRC/cggrqf.f @@ -1,7 +1,7 @@ SUBROUTINE CGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggsvd.f b/SRC/cggsvd.f index 416be61b..6dd3a7e1 100644 --- a/SRC/cggsvd.f +++ b/SRC/cggsvd.f @@ -2,7 +2,7 @@ $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cggsvp.f b/SRC/cggsvp.f index 5aafb5fd..dd4feeef 100644 --- a/SRC/cggsvp.f +++ b/SRC/cggsvp.f @@ -2,7 +2,7 @@ $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, RWORK, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -110,7 +110,7 @@ * The leading dimension of the array U. LDU >= max(1,M) if * JOBU = 'U'; LDU >= 1 otherwise. * -* V (output) COMPLEX array, dimension (LDV,M) +* V (output) COMPLEX array, dimension (LDV,P) * If JOBV = 'V', V contains the unitary matrix V. * If JOBV = 'N', V is not referenced. * diff --git a/SRC/cgtcon.f b/SRC/cgtcon.f index cf54a837..a6914a0f 100644 --- a/SRC/cgtcon.f +++ b/SRC/cgtcon.f @@ -1,7 +1,7 @@ SUBROUTINE CGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgtrfs.f b/SRC/cgtrfs.f index 4794b460..5fee190f 100644 --- a/SRC/cgtrfs.f +++ b/SRC/cgtrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgtsv.f b/SRC/cgtsv.f index cde1ce9b..260ceaa4 100644 --- a/SRC/cgtsv.f +++ b/SRC/cgtsv.f @@ -1,6 +1,6 @@ SUBROUTINE CGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgtsvx.f b/SRC/cgtsvx.f index 4e73b7fb..cfb47c30 100644 --- a/SRC/cgtsvx.f +++ b/SRC/cgtsvx.f @@ -2,7 +2,7 @@ $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgttrf.f b/SRC/cgttrf.f index 914e3266..fbe5313a 100644 --- a/SRC/cgttrf.f +++ b/SRC/cgttrf.f @@ -1,6 +1,6 @@ SUBROUTINE CGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgttrs.f b/SRC/cgttrs.f index 2da12aca..1e311100 100644 --- a/SRC/cgttrs.f +++ b/SRC/cgttrs.f @@ -1,7 +1,7 @@ SUBROUTINE CGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cgtts2.f b/SRC/cgtts2.f index 840a9199..d190e45a 100644 --- a/SRC/cgtts2.f +++ b/SRC/cgtts2.f @@ -1,6 +1,6 @@ SUBROUTINE CGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbev.f b/SRC/chbev.f index 96b44423..e2200052 100644 --- a/SRC/chbev.f +++ b/SRC/chbev.f @@ -1,7 +1,7 @@ SUBROUTINE CHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbevd.f b/SRC/chbevd.f index e37bdd0f..cbac0dd9 100644 --- a/SRC/chbevd.f +++ b/SRC/chbevd.f @@ -1,7 +1,7 @@ SUBROUTINE CHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbevx.f b/SRC/chbevx.f index 19abc5c5..09e6581a 100644 --- a/SRC/chbevx.f +++ b/SRC/chbevx.f @@ -2,7 +2,7 @@ $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbgst.f b/SRC/chbgst.f index 2ed563fb..ceab0c1d 100644 --- a/SRC/chbgst.f +++ b/SRC/chbgst.f @@ -1,7 +1,7 @@ SUBROUTINE CHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbgv.f b/SRC/chbgv.f index 0230cda9..86c940e2 100644 --- a/SRC/chbgv.f +++ b/SRC/chbgv.f @@ -1,7 +1,7 @@ SUBROUTINE CHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbgvd.f b/SRC/chbgvd.f index f93ed18d..aeb0c350 100644 --- a/SRC/chbgvd.f +++ b/SRC/chbgvd.f @@ -2,7 +2,7 @@ $ Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbgvx.f b/SRC/chbgvx.f index 5e6ab664..d66fe6f8 100644 --- a/SRC/chbgvx.f +++ b/SRC/chbgvx.f @@ -2,7 +2,7 @@ $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chbtrd.f b/SRC/chbtrd.f index cff1efeb..456b154d 100644 --- a/SRC/chbtrd.f +++ b/SRC/chbtrd.f @@ -1,7 +1,7 @@ SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/checon.f b/SRC/checon.f index 0a422ccc..bb95d663 100644 --- a/SRC/checon.f +++ b/SRC/checon.f @@ -1,7 +1,7 @@ SUBROUTINE CHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cheequb.f b/SRC/cheequb.f new file mode 100644 index 00000000..30e72709 --- /dev/null +++ b/SRC/cheequb.f @@ -0,0 +1,255 @@ + SUBROUTINE CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + REAL AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), WORK( * ) + REAL S( * ) +* .. +* +* Purpose +* ======= +* +* CSYEQUB computes row and column scalings intended to equilibrate a +* symmetric matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The N-by-N symmetric matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) REAL array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) REAL +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + REAL AVG, STD, TOL, C0, C1, C2, T, U, SI, D, + $ BASE, SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP + COMPLEX ZDUM +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLASSQ +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* +* Test input parameters. +* + INFO = 0 + IF (.NOT. ( LSAME( UPLO, 'U' ) .OR. 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( 'CHEEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) + END DO + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A(I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0 / S( J ) + END DO + + TOL = ONE / SQRT( 2.0E0 * N ) + + DO ITER = 1, MAX_ITER + SCALE = 0.0 + SUMSQ = 0.0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0 + DO I = 2*N+1, 3*N + WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG + END DO + CALL CLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + + D = C1*C1 - 4*C0*C2 + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S(I) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO + + END DO + + 999 CONTINUE + + SMLNUM = SLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT( AVG ) + BASE = SLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + + END diff --git a/SRC/cheev.f b/SRC/cheev.f index 78fa34d7..c931eefb 100644 --- a/SRC/cheev.f +++ b/SRC/cheev.f @@ -1,7 +1,7 @@ SUBROUTINE CHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cheevd.f b/SRC/cheevd.f index 79490a6e..6e3013a9 100644 --- a/SRC/cheevd.f +++ b/SRC/cheevd.f @@ -1,7 +1,7 @@ SUBROUTINE CHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cheevr.f b/SRC/cheevr.f index 6e63948b..3c40390b 100644 --- a/SRC/cheevr.f +++ b/SRC/cheevr.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cheevx.f b/SRC/cheevx.f index a484ead4..bb4e6782 100644 --- a/SRC/cheevx.f +++ b/SRC/cheevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chegs2.f b/SRC/chegs2.f index 5bc7869c..27889836 100644 --- a/SRC/chegs2.f +++ b/SRC/chegs2.f @@ -1,6 +1,6 @@ SUBROUTINE CHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chegst.f b/SRC/chegst.f index f29d29e3..9632edba 100644 --- a/SRC/chegst.f +++ b/SRC/chegst.f @@ -1,6 +1,6 @@ SUBROUTINE CHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chegv.f b/SRC/chegv.f index f68db722..a182dc5a 100644 --- a/SRC/chegv.f +++ b/SRC/chegv.f @@ -1,7 +1,7 @@ SUBROUTINE CHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chegvd.f b/SRC/chegvd.f index d8e592ec..c1109b03 100644 --- a/SRC/chegvd.f +++ b/SRC/chegvd.f @@ -1,7 +1,7 @@ SUBROUTINE CHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chegvx.f b/SRC/chegvx.f index 1566e535..8e7aff01 100644 --- a/SRC/chegvx.f +++ b/SRC/chegvx.f @@ -2,7 +2,7 @@ $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cherfs.f b/SRC/cherfs.f index 673026dc..abea730e 100644 --- a/SRC/cherfs.f +++ b/SRC/cherfs.f @@ -1,7 +1,7 @@ SUBROUTINE CHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cherfsx.f b/SRC/cherfsx.f new file mode 100644 index 00000000..f1ad2a30 --- /dev/null +++ b/SRC/cherfsx.f @@ -0,0 +1,573 @@ + Subroutine CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* +* Purpose +* ======= +* +* CHERFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is Hermitian indefinite, and +* provides error bounds and backward error estimates for the +* solution. In addition to normwise error bound, the code provides +* maximum componentwise error bound if possible. See comments for +* ERR_BNDS_N and ERR_BNDS_C for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX array, dimension (LDAF,N) +* The factored form of the matrix A. AF contains the block +* diagonal matrix D and the multipliers used to obtain the +* factor U or L from the factorization A = U*D*U**T or A = +* L*D*L**T as computed by SSYTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by SSYTRF. +* +* S (input or output) REAL array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) COMPLEX array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHECON, CLA_HERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, CLANHE, CLA_HERCOND_X, CLA_HERCOND_C + REAL SLAMCH, CLANHE, CLA_HERCOND_X, CLA_HERCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS(LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = CLANHE( NORM, UPLO, N, A, LDA, WORK ) + CALL CHECON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + CALL CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK(N+1), WORK(1), WORK(2*N+1), WORK(1), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF (RCOND_TMP .LT. ILLRCOND_THRESH) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, + $ IPIV, X( 1, J ), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of CHERFSX +* + END diff --git a/SRC/chesv.f b/SRC/chesv.f index f51025e4..4cc97e3a 100644 --- a/SRC/chesv.f +++ b/SRC/chesv.f @@ -1,7 +1,7 @@ SUBROUTINE CHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chesvx.f b/SRC/chesvx.f index bb9d5d2a..1ef2253d 100644 --- a/SRC/chesvx.f +++ b/SRC/chesvx.f @@ -2,7 +2,7 @@ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chesvxx.f b/SRC/chesvxx.f new file mode 100644 index 00000000..5183d7b6 --- /dev/null +++ b/SRC/chesvxx.f @@ -0,0 +1,561 @@ + SUBROUTINE CHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ WORK( * ), X( LDX, * ) + REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* CHESVXX uses the diagonal pivoting factorization to compute the +* solution to a complex system of linear equations A * X = B, where +* A is an N-by-N symmetric matrix and X and B are N-by-NRHS +* matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. CHESVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* CHESVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* CHESVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what CHESVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = U * D * U**T, if UPLO = 'U', or +* A = L * D * L**T, if UPLO = 'L', +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* 3. If some D(i,i)=0, so that D is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is +* less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(R) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T as computed by SSYTRF. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains details of the interchanges and the block +* structure of D, as determined by SSYTRF. If IPIV(k) > 0, +* then rows and columns k and IPIV(k) were interchanged and +* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +* then rows and columns k+1 and -IPIV(k) were interchanged +* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains details of the interchanges and the block +* structure of D, as determined by SSYTRF. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) REAL array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) COMPLEX array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) COMPLEX array, dimension (2*N) +* +* RWORK (workspace) REAL array, dimension (3*N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, CLA_HERPVGRW + LOGICAL LSAME + REAL SLAMCH, CLA_HERPVGRW +* .. +* .. External Subroutines .. + EXTERNAL CHECON, CHEEQUB, CHETRF, CHETRS, CLACPY, + $ CLAQHE, XERBLA, CLASCL2, CHERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in CHERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until CHERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL CHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL CLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL CLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL CHETRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF( N.GT.0 ) + $ RPVGRW = CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF( N.GT.0 ) + $ RPVGRW = CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, + $ WORK ) +* +* Compute the solution matrix X. +* + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL CHETRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL CHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL CLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of CHESVXX +* + END diff --git a/SRC/chetd2.f b/SRC/chetd2.f index e1b51f2a..baba8b44 100644 --- a/SRC/chetd2.f +++ b/SRC/chetd2.f @@ -1,6 +1,6 @@ SUBROUTINE CHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chetf2.f b/SRC/chetf2.f index 022cbc78..e929e883 100644 --- a/SRC/chetf2.f +++ b/SRC/chetf2.f @@ -1,6 +1,6 @@ SUBROUTINE CHETF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chetrd.f b/SRC/chetrd.f index a9166577..e7116e5f 100644 --- a/SRC/chetrd.f +++ b/SRC/chetrd.f @@ -1,6 +1,6 @@ SUBROUTINE CHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chetrf.f b/SRC/chetrf.f index 520bc356..b4392e7d 100644 --- a/SRC/chetrf.f +++ b/SRC/chetrf.f @@ -1,6 +1,6 @@ SUBROUTINE CHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chetri.f b/SRC/chetri.f index 8bf8500e..27c8731d 100644 --- a/SRC/chetri.f +++ b/SRC/chetri.f @@ -1,6 +1,6 @@ SUBROUTINE CHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chetrs.f b/SRC/chetrs.f index 8a96f3f6..693d3222 100644 --- a/SRC/chetrs.f +++ b/SRC/chetrs.f @@ -1,6 +1,6 @@ SUBROUTINE CHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chfrk.f b/SRC/chfrk.f new file mode 100644 index 00000000..caa71844 --- /dev/null +++ b/SRC/chfrk.f @@ -0,0 +1,478 @@ + SUBROUTINE CHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, + + C ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER K, LDA, N + CHARACTER TRANS, TRANSR, UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), C( * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for C in RFP Format. +* +* CHFRK performs one of the Hermitian rank--k operations +* +* C := alpha*A*conjg( A' ) + beta*C, +* +* or +* +* C := alpha*conjg( A' )*A + beta*C, +* +* where alpha and beta are real scalars, C is an n--by--n Hermitian +* matrix and A is an n--by--k matrix in the first case and a k--by--n +* matrix in the second case. +* +* Arguments +* ========== +* +* TRANSR - (input) CHARACTER. +* = 'N': The Normal Form of RFP A is stored; +* = 'C': The Conjugate-transpose Form of RFP A is stored. +* +* UPLO - (input) CHARACTER. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array C is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of C +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of C +* is to be referenced. +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. +* +* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. +* +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the order of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - (input) INTEGER. +* On entry with TRANS = 'N' or 'n', K specifies the number +* of columns of the matrix A, and on entry with +* TRANS = 'C' or 'c', K specifies the number of rows of the +* matrix A. K must be at least zero. +* Unchanged on exit. +* +* ALPHA - (input) REAL. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - (input) COMPLEX array of DIMENSION ( LDA, ka ), where KA +* is K when TRANS = 'N' or 'n', and is N otherwise. Before +* entry with TRANS = 'N' or 'n', the leading N--by--K part of +* the array A must contain the matrix A, otherwise the leading +* K--by--N part of the array A must contain the matrix A. +* Unchanged on exit. +* +* LDA - (input) INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDA must be at least max( 1, n ), otherwise LDA must +* be at least max( 1, k ). +* Unchanged on exit. +* +* BETA - (input) REAL. +* On entry, BETA specifies the scalar beta. +* Unchanged on exit. +* +* C - (input/output) COMPLEX array, dimension ( N*(N+1)/2 ). +* On entry, the matrix A in RFP Format. RFP Format is +* described by TRANSR, UPLO and N. Note that the imaginary +* parts of the diagonal elements need not be set, they are +* assumed to be zero, and on exit they are set to zero. +* +* Arguments +* ========== +* +* .. +* .. Parameters .. + REAL ONE, ZERO + COMPLEX CZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS + INTEGER INFO, NROWA, J, NK, N1, N2 + COMPLEX CALPHA, CBETA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CGEMM, CHERK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, CMPLX +* .. +* .. Executable Statements .. +* +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) +* + IF( NOTRANS ) THEN + NROWA = N + ELSE + NROWA = K + END IF +* + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CHFRK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* +* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not +* done (it is in CHERK for example) and left in the general case. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + + ( BETA.EQ.ONE ) ) )RETURN +* + IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN + DO J = 1, ( ( N*( N+1 ) ) / 2 ) + C( J ) = CZERO + END DO + RETURN + END IF +* + CALPHA = CMPLX( ALPHA, ZERO ) + CBETA = CMPLX( BETA, ZERO ) +* +* C is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and NK. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + NK = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL CHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL CHERK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N+1 ), N ) + CALL CGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' +* + CALL CHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL CHERK( 'U', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N+1 ), N ) + CALL CGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL CHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL CHERK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, + + BETA, C( N1+1 ), N ) + CALL CGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( N2, 1 ), LDA, CBETA, C( 1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' +* + CALL CHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL CHERK( 'U', 'C', N2, K, ALPHA, A( 1, N2 ), LDA, + + BETA, C( N1+1 ), N ) + CALL CGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, N2 ), LDA, CBETA, C( 1 ), N ) +* + END IF +* + END IF +* + ELSE +* +* N is odd, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' +* + CALL CHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL CHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL CGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( N1+1, 1 ), LDA, CBETA, + + C( N1*N1+1 ), N1 ) +* + ELSE +* +* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' +* + CALL CHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL CHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL CGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, N1+1 ), LDA, CBETA, + + C( N1*N1+1 ), N1 ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' +* + CALL CHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL CHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL CGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 ) +* + ELSE +* +* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' +* + CALL CHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL CHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL CGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL CHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL CHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' +* + CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ), + + N+1 ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL CHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL CHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, CBETA, C( 1 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' +* + CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, CBETA, C( 1 ), + + N+1 ) +* + END IF +* + END IF +* + ELSE +* +* N is even, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' +* + CALL CHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL CHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), NK ) + CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, CBETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' +* + CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), NK ) + CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, CBETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' +* + CALL CHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL CHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL CGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' +* + CALL CHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL CHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL CGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK ) +* + END IF +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CHFRK +* + END diff --git a/SRC/chgeqz.f b/SRC/chgeqz.f index 9593179a..b05dd8c2 100644 --- a/SRC/chgeqz.f +++ b/SRC/chgeqz.f @@ -2,7 +2,7 @@ $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chla_transtype.f b/SRC/chla_transtype.f new file mode 100644 index 00000000..687cc25c --- /dev/null +++ b/SRC/chla_transtype.f @@ -0,0 +1,49 @@ + CHARACTER*1 FUNCTION CHLA_TRANSTYPE( TRANS ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* October 2008 +* .. Scalar Arguments .. + INTEGER TRANS +* .. +* +* Purpose +* ======= +* +* This subroutine translates from a BLAST-specified integer constant to +* the character string specifying a transposition operation. +* +* CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE is 'X', +* then input is not an integer indicating a transposition operator. +* Otherwise CHLA_TRANSTYPE returns the constant value corresponding to +* TRANS. +* +* Arguments +* ========= +* TRANS (input) INTEGER +* Specifies the form of the system of equations: +* = BLAS_NO_TRANS = 111 : No Transpose +* = BLAS_TRANS = 112 : Transpose +* = BLAS_CONJ_TRANS = 113 : Conjugate Transpose +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS + PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, + $ BLAS_CONJ_TRANS = 113 ) +* .. +* .. Executable Statements .. + IF( TRANS.EQ.BLAS_NO_TRANS ) THEN + CHLA_TRANSTYPE = 'N' + ELSE IF( TRANS.EQ.BLAS_TRANS ) THEN + CHLA_TRANSTYPE = 'T' + ELSE IF( TRANS.EQ.BLAS_CONJ_TRANS ) THEN + CHLA_TRANSTYPE = 'C' + ELSE + CHLA_TRANSTYPE = 'X' + END IF + RETURN +* +* End of CHLA_TRANSTYPE +* + END diff --git a/SRC/chpcon.f b/SRC/chpcon.f index 8ff610c7..dab1f42b 100644 --- a/SRC/chpcon.f +++ b/SRC/chpcon.f @@ -1,6 +1,6 @@ SUBROUTINE CHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpev.f b/SRC/chpev.f index 855203ba..b73a7dc3 100644 --- a/SRC/chpev.f +++ b/SRC/chpev.f @@ -1,7 +1,7 @@ SUBROUTINE CHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpevd.f b/SRC/chpevd.f index bbb53503..0f3447f2 100644 --- a/SRC/chpevd.f +++ b/SRC/chpevd.f @@ -1,7 +1,7 @@ SUBROUTINE CHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpevx.f b/SRC/chpevx.f index 0a2e36d4..1fa8e8eb 100644 --- a/SRC/chpevx.f +++ b/SRC/chpevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -336,7 +336,7 @@ * INDWRK = INDTAU + N CALL CUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), INFO ) + $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. diff --git a/SRC/chpgst.f b/SRC/chpgst.f index 3d727010..52940d30 100644 --- a/SRC/chpgst.f +++ b/SRC/chpgst.f @@ -1,6 +1,6 @@ SUBROUTINE CHPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpgv.f b/SRC/chpgv.f index ce937f06..bbc593c4 100644 --- a/SRC/chpgv.f +++ b/SRC/chpgv.f @@ -1,7 +1,7 @@ SUBROUTINE CHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpgvd.f b/SRC/chpgvd.f index 970fce4e..64ee833e 100644 --- a/SRC/chpgvd.f +++ b/SRC/chpgvd.f @@ -1,7 +1,7 @@ SUBROUTINE CHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpgvx.f b/SRC/chpgvx.f index 4370b9df..9e7e64fb 100644 --- a/SRC/chpgvx.f +++ b/SRC/chpgvx.f @@ -2,7 +2,7 @@ $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chprfs.f b/SRC/chprfs.f index e278aaa2..7f5b4b3d 100644 --- a/SRC/chprfs.f +++ b/SRC/chprfs.f @@ -1,7 +1,7 @@ SUBROUTINE CHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpsv.f b/SRC/chpsv.f index 78091e06..5c429a76 100644 --- a/SRC/chpsv.f +++ b/SRC/chpsv.f @@ -1,6 +1,6 @@ SUBROUTINE CHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chpsvx.f b/SRC/chpsvx.f index dca6e736..06ccfc8c 100644 --- a/SRC/chpsvx.f +++ b/SRC/chpsvx.f @@ -1,7 +1,7 @@ SUBROUTINE CHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chptrd.f b/SRC/chptrd.f index 07c146e4..704d9237 100644 --- a/SRC/chptrd.f +++ b/SRC/chptrd.f @@ -1,6 +1,6 @@ SUBROUTINE CHPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chptrf.f b/SRC/chptrf.f index 65ab2192..cb980e47 100644 --- a/SRC/chptrf.f +++ b/SRC/chptrf.f @@ -1,6 +1,6 @@ SUBROUTINE CHPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chptri.f b/SRC/chptri.f index 298d6533..71a61aaf 100644 --- a/SRC/chptri.f +++ b/SRC/chptri.f @@ -1,6 +1,6 @@ SUBROUTINE CHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chptrs.f b/SRC/chptrs.f index 9767860a..58a13045 100644 --- a/SRC/chptrs.f +++ b/SRC/chptrs.f @@ -1,6 +1,6 @@ SUBROUTINE CHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chsein.f b/SRC/chsein.f index 7d93c686..c9533127 100644 --- a/SRC/chsein.f +++ b/SRC/chsein.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/chseqr.f b/SRC/chseqr.f index 42977fd2..597b79e6 100644 --- a/SRC/chseqr.f +++ b/SRC/chseqr.f @@ -1,8 +1,8 @@ SUBROUTINE CHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK driver routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -95,9 +95,11 @@ * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. +* is sufficient and delivers very good and sometimes +* optimal performance. However, LWORK as large as 11*N +* may be required for optimal performance. A workspace +* query is recommended to determine the optimal workspace +* size. * * If LWORK = -1, then CHSEQR does a workspace query. * In this case, CHSEQR checks the input parameters and @@ -152,46 +154,50 @@ * to attain best performance in each particular * computational environment. * -* ISPEC=1: The CLAHQR vs CLAQR0 crossover point. +* ISPEC=12: The CLAHQR vs CLAQR0 crossover point. * Default: 75. (Must be at least 11.) * -* ISPEC=2: Recommended deflation window size. +* ISPEC=13: Recommended deflation window size. * This depends on ILO, IHI and NS. NS is the * number of simultaneous shifts returned -* by ILAENV(ISPEC=4). (See ISPEC=4 below.) +* by ILAENV(ISPEC=15). (See ISPEC=15 below.) * The default for (IHI-ILO+1).LE.500 is NS. * The default for (IHI-ILO+1).GT.500 is 3*NS/2. * -* ISPEC=3: Nibble crossover point. (See ILAENV for +* ISPEC=14: Nibble crossover point. (See IPARMQ for * details.) Default: 14% of deflation window * size. * -* ISPEC=4: Number of simultaneous shifts, NS, in -* a multi-shift QR iteration. +* ISPEC=15: Number of simultaneous shifts in a multishift +* QR iteration. * * If IHI-ILO+1 is ... * * greater than ...but less ... the * or equal to ... than default is * -* 1 30 NS - 2(+) -* 30 60 NS - 4(+) +* 1 30 NS = 2(+) +* 30 60 NS = 4(+) * 60 150 NS = 10(+) * 150 590 NS = ** * 590 3000 NS = 64 * 3000 6000 NS = 128 * 6000 infinity NS = 256 * -* (+) By default some or all matrices of this order +* (+) By default some or all matrices of this order * are passed to the implicit double shift routine -* CLAHQR and NS is ignored. See ISPEC=1 above -* and comments in IPARM for details. +* CLAHQR and this parameter is ignored. See +* ISPEC=12 above and comments in IPARMQ for +* details. * -* The asterisks (**) indicate an ad-hoc +* (**) The asterisks (**) indicate an ad-hoc * function of N increasing from 10 to 64. * -* ISPEC=5: Select structured matrix multiply. -* (See ILAENV for details.) Default: 3. +* ISPEC=16: Select structured matrix multiply. +* If the number of simultaneous shifts (specified +* by ISPEC=15) is less than 14, then the default +* for ISPEC=16 is 0. Otherwise the default for +* ISPEC=16 is 2. * * ================================================================ * Based on contributions by @@ -215,16 +221,15 @@ * ==== Matrices of order NTINY or smaller must be processed by * . CLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare CLAHQR failure. NL .GT. NTINY = 11 is -* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) INTEGER NL PARAMETER ( NL = 49 ) COMPLEX ZERO, ONE @@ -328,8 +333,8 @@ * * ==== CLAHQR/CLAQR0 crossover point ==== * - NMIN = ILAENV( 1, 'CHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, - $ IHI, LWORK ) + NMIN = ILAENV( 12, 'CHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== CLAQR0 for big matrices; CLAHQR for small ones ==== diff --git a/SRC/cla_gbamv.f b/SRC/cla_gbamv.f new file mode 100644 index 00000000..28dc88a6 --- /dev/null +++ b/SRC/cla_gbamv.f @@ -0,0 +1,290 @@ + SUBROUTINE CLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, + $ INCX, BETA, Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS +* .. +* .. Array Arguments .. + COMPLEX AB( LDAB, * ), X( * ) + REAL Y( * ) +* .. +* +* Purpose +* ======= +* +* SLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* KL - INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU - INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* ALPHA - REAL +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - REAL array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* .. +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD + COMPLEX CDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, REAL, AIMAG, SIGN +* .. +* .. Statement Functions + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( KL.LT.0 ) THEN + INFO = 4 + ELSE IF( KU.LT.0 ) THEN + INFO = 5 + ELSE IF( LDAB.LT.KL+KU+1 )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'CLA_GBAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + KD = KU + 1 + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0 ) THEN + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( AB( KD+I-J, J ) ) + ELSE + TEMP = CABS1( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0 ) THEN + JX = KX + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( AB( KD+I-J, J ) ) + ELSE + TEMP = CABS1( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of CLA_GBAMV +* + END diff --git a/SRC/cla_gbrcond_c.f b/SRC/cla_gbrcond_c.f new file mode 100644 index 00000000..a8de1799 --- /dev/null +++ b/SRC/cla_gbrcond_c.f @@ -0,0 +1,192 @@ + REAL FUNCTION CLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, C, CAPPLY, INFO, WORK, + $ RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + LOGICAL CAPPLY + INTEGER N, KL, KU, KD, LDAB, LDAFB, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) + REAL C( * ), RWORK( * ) +* +* CLA_GBRCOND_C Computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a REAL vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + REAL AINVNM, ANORM, TMP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + CLA_GBRCOND_C = 0.0E+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_GBRCOND_C', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0E+0 + KD = KU + 1 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1(AB( KD+I-J, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( KD+I-J, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( J, KD+I-J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( J, KD+I-J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_GBRCOND_C = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( NOTRANS ) THEN + CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( NOTRANS ) THEN + CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ELSE + CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_GBRCOND_C = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_gbrcond_x.f b/SRC/cla_gbrcond_x.f new file mode 100644 index 00000000..a0e04f33 --- /dev/null +++ b/SRC/cla_gbrcond_x.f @@ -0,0 +1,169 @@ + REAL FUNCTION CLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, X, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, KL, KU, KD, LDAB, LDAFB, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), + $ X( * ) + REAL RWORK( * ) +* +* CLA_GBRCOND_X Computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + REAL AINVNM, ANORM, TMP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_GBRCOND_X = 0.0E+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_GBRCOND_X', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + KD = KU + 1 + ANORM = 0.0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( KD+I-J, J) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( J, KD+I-J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_GBRCOND_X = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( NOTRANS ) THEN + CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( NOTRANS ) THEN + CALL CGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ELSE + CALL CGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_GBRCOND_X = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_gbrfsx_extended.f b/SRC/cla_gbrfsx_extended.f new file mode 100644 index 00000000..d5eab504 --- /dev/null +++ b/SRC/cla_gbrfsx_extended.f @@ -0,0 +1,310 @@ + SUBROUTINE CLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, + $ COLEQU, C, B, LDB, Y, LDY, + $ BERR_OUT, N_NORMS, ERRS_N, ERRS_C, + $ RES, AYB, DY, Y_TAIL, RCOND, + $ ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, + $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB(*), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CCOPY, CGBTRS, CGBMV, BLAS_CGBMV_X, + $ BLAS_CGBMV2_X, CLA_GBAMV, CLA_WWADDW, SLAMCH, + $ CHLA_TRANSTYPE, CLA_LIN_BERR + REAL SLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions.. + INTRINSIC ABS, MAX, MIN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS + M = KL+KU+1 + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) then + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0E+0 + DXRATMAX = 0.0E+0 + DZRAT = 0.0E+0 + DZRATMAX = 0.0E+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL CGBMV( TRANS, M, N, KL, KU, (-1.0E+0,0.0E+0), AB, + $ LDAB, Y( 1, J ), 1, (1.0E+0,0.0E+0), RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_CGBMV_X( TRANS_TYPE, N, N, KL, KU, + $ (-1.0E+0,0.0E+0), AB, LDAB, Y( 1, J ), 1, + $ (1.0E+0,0.0E+0), RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_CGBMV2_X( TRANS_TYPE, N, N, KL, KU, + $ (-1.0E+0,0.0E+0), AB, LDAB, Y( 1, J ), Y_TAIL, 1, + $ (1.0E+0,0.0E+0), RES, 1, PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL CCOPY( N, RES, 1, DY, 1 ) + CALL CGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, DY, N, + $ INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0E+0 + NORMY = 0.0E+0 + NORMDX = 0.0E+0 + DZ_Z = 0.0E+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF (YK .NE. 0.0) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX(NORMDX, DYK * C(I)) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL CAXPY( N, (1.0E+0,0.0E+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL CLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL CGBMV( TRANS, N, N, KL, KU, (-1.0E+0,0.0E+0), AB, LDAB, + $ Y(1,J), 1, (1.0E+0,0.0E+0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL CLA_GBAMV( TRANS_TYPE, N, N, KL, KU, 1.0E+0, + $ AB, LDAB, Y(1, J), 1, 1.0E+0, AYB, 1 ) + + CALL CLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/cla_gbrpvgrw.f b/SRC/cla_gbrpvgrw.f new file mode 100644 index 00000000..f486e1e6 --- /dev/null +++ b/SRC/cla_gbrpvgrw.f @@ -0,0 +1,53 @@ + REAL FUNCTION CLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, + $ LDAFB ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, KL, KU, NCOLS, LDAB, LDAFB +* .. +* .. Array Arguments .. + COMPLEX AB( LDAB, * ), AFB( LDAFB, * ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + REAL AMAX, UMAX, RPVGRW + COMPLEX ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0 +* + KD = KU + 1 + DO J = 1, NCOLS + AMAX = 0.0 + UMAX = 0.0 + DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) + AMAX = MAX( CABS1( AB( KD+I-J, J ) ), AMAX ) + END DO + DO I = MAX( J-KU, 1 ), J + UMAX = MAX( CABS1( AFB( KD+I-J, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + CLA_GBRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/cla_geamv.f b/SRC/cla_geamv.f new file mode 100644 index 00000000..66c962ff --- /dev/null +++ b/SRC/cla_geamv.f @@ -0,0 +1,280 @@ + SUBROUTINE CLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, + $ Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + INTEGER TRANS +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), X( * ) + REAL Y( * ) +* .. +* +* Purpose +* ======= +* +* CLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - REAL +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - COMPLEX array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - COMPLEX array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* .. +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY + COMPLEX CDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, REAL, AIMAG, SIGN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'CLA_GEAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0 ) THEN + DO J = 1, LENX + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) Y( IY ) = + $ Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. 0.0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0 ) THEN + JX = KX + DO J = 1, LENX + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) Y( IY ) = + $ Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of CLA_GEAMV +* + END diff --git a/SRC/cla_gercond_c.f b/SRC/cla_gercond_c.f new file mode 100644 index 00000000..e6a16635 --- /dev/null +++ b/SRC/cla_gercond_c.f @@ -0,0 +1,178 @@ + REAL FUNCTION CLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, C, + $ CAPPLY, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Aguments .. + CHARACTER TRANS + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) + REAL C( * ), RWORK( * ) +* +* CLA_GERCOND_C computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a REAL vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + REAL AINVNM, ANORM, TMP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + CLA_GERCOND_C = 0.0E+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_GERCOND_C', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0E+0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END DO + ELSE + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) ) + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + END DO + ELSE + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) ) + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_GERCOND_C = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF (NOTRANS) THEN + CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( NOTRANS ) THEN + CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_GERCOND_C = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_gercond_x.f b/SRC/cla_gercond_x.f new file mode 100644 index 00000000..189322a8 --- /dev/null +++ b/SRC/cla_gercond_x.f @@ -0,0 +1,162 @@ + REAL FUNCTION CLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, IPIV, X, + $ INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + REAL RWORK( * ) +* +* CLA_GERCOND_X computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE + REAL AINVNM, ANORM, TMP + INTEGER I, J + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_GERCOND_X = 0.0E+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_GERCOND_X', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_GERCOND_X = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* Multiply by R. + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( NOTRANS ) THEN + CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( NOTRANS ) THEN + CALL CGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_GERCOND_X = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_gerfsx_extended.f b/SRC/cla_gerfsx_extended.f new file mode 100644 index 00000000..90ba5bd9 --- /dev/null +++ b/SRC/cla_gerfsx_extended.f @@ -0,0 +1,310 @@ + SUBROUTINE CLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, + $ LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, Y, LDY, BERR_OUT, N_NORMS, + $ ERRS_N, ERRS_C, RES, AYB, DY, + $ Y_TAIL, RCOND, ITHRESH, RTHRESH, + $ DZ_UB, IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ TRANS_TYPE, N_NORMS + LOGICAL COLEQU, IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, + $ NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CCOPY, CGETRS, CGEMV, BLAS_CGEMV_X, + $ BLAS_CGEMV2_X, CLA_GEAMV, CLA_WWADDW, SLAMCH, + $ CHLA_TRANSTYPE, CLA_LIN_BERR + REAL SLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS +* + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL CGEMV( TRANS, N, N, (-1.0E+0,0.0E+0), A, LDA, + $ Y( 1, J ), 1, (1.0E+0,0.0E+0), RES, 1) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_CGEMV_X( TRANS_TYPE, N, N, (-1.0E+0,0.0E+0), A, + $ LDA, Y( 1, J ), 1, (1.0E+0,0.0E+0), + $ RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_CGEMV2_X( TRANS_TYPE, N, N, (-1.0E+0,0.0E+0), + $ A, LDA, Y(1, J), Y_TAIL, 1, (1.0E+0,0.0E+0), RES, 1, + $ PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL CCOPY( N, RES, 1, DY, 1 ) + CALL CGETRS( TRANS, N, 1, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0E+0 + NORMY = 0.0E+0 + NORMDX = 0.0E+0 + DZ_Z = 0.0E+0 + YMIN = HUGEVAL +* + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF ( YK .NE. 0.0E+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF (DX_X .LE. EPS) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL CAXPY( N, (1.0E+0,0.0E+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL CLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL CGEMV( TRANS, N, N, (-1.0E+0,0.0E+0), A, LDA, Y(1,J), 1, + $ (1.0E+0,0.0E+0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL CLA_GEAMV ( TRANS_TYPE, N, N, 1.0E+0, + $ A, LDA, Y(1, J), 1, 1.0E+0, AYB, 1 ) + + CALL CLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/cla_heamv.f b/SRC/cla_heamv.f new file mode 100644 index 00000000..4ffaaca0 --- /dev/null +++ b/SRC/cla_heamv.f @@ -0,0 +1,283 @@ + SUBROUTINE CLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDA, N, UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), X( * ) + REAL Y( * ) +* .. +* +* Purpose +* ======= +* +* CLA_SYAMV performs the matrix-vector operation +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* n by n symmetric matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* UPLO - INTEGER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = BLAS_UPPER Only the upper triangular part of A +* is to be referenced. +* +* UPLO = BLAS_LOWER Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - REAL . +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - COMPLEX array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - COMPLEX array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL . +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCY ) ) +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* -- Modified for the absolute-value product, April 2006 +* Jason Riedy, UC Berkeley +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY + COMPLEX ZDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'CHEMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF (.NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of CLA_HEAMV +* + END diff --git a/SRC/cla_hercond_c.f b/SRC/cla_hercond_c.f new file mode 100644 index 00000000..2422b5b4 --- /dev/null +++ b/SRC/cla_hercond_c.f @@ -0,0 +1,194 @@ + REAL FUNCTION CLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, + $ CAPPLY, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) + REAL C ( * ), RWORK( * ) +* +* CLA_HERCOND_C computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a REAL vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + REAL AINVNM, ANORM, TMP + LOGICAL UP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CHETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_HERCOND_C = 0.0E+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_HERCOND_C', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0E+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_HERCOND_C = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( UP ) THEN + CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_HERCOND_C = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_hercond_x.f b/SRC/cla_hercond_x.f new file mode 100644 index 00000000..7a042ec8 --- /dev/null +++ b/SRC/cla_hercond_x.f @@ -0,0 +1,169 @@ + REAL FUNCTION CLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, + $ INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + REAL RWORK( * ) +* +* CLA_HERCOND_X computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + REAL AINVNM, ANORM, TMP + LOGICAL UP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CHETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_HERCOND_X = 0.0E+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_HERCOND_X', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_HERCOND_X = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( UP ) THEN + CALL CHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_HERCOND_X = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_herfsx_extended.f b/SRC/cla_herfsx_extended.f new file mode 100644 index 00000000..d0c5a5fa --- /dev/null +++ b/SRC/cla_herfsx_extended.f @@ -0,0 +1,307 @@ + SUBROUTINE CLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE, + $ Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CCOPY, CHETRS, CHEMV, BLAS_CHEMV_X, + $ BLAS_CHEMV2_X, CLA_HEAMV, CLA_WWADDW, + $ CLA_LIN_BERR + REAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, AIMAG, MAX, MIN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL CHEMV( UPLO, N, CMPLX(-1.0), A, LDA, Y( 1, J ), 1, + $ CMPLX(1.0), RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_CHEMV_X( UPLO2, N, CMPLX(-1.0), A, LDA, + $ Y( 1, J ), 1, CMPLX(1.0), RES, 1, PREC_TYPE) + ELSE + CALL BLAS_CHEMV2_X(UPLO2, N, CMPLX(-1.0), A, LDA, + $ Y(1, J), Y_TAIL, 1, CMPLX(1.0), RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL CCOPY( N, RES, 1, DY, 1 ) + CALL CHETRS( UPLO, N, NRHS, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF (YK .NE. 0.0) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF (DXRAT .GT. DXRATMAX) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL CAXPY( N, CMPLX(1.0), DY, 1, Y(1,J), 1 ) + ELSE + CALL CLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL CHEMV( UPLO, N, CMPLX(-1.0), A, LDA, Y(1,J), 1, + $ CMPLX(1.0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL CLA_HEAMV( UPLO2, N, 1.0, + $ A, LDA, Y(1, J), 1, 1.0, AYB, 1 ) + + CALL CLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/cla_herpvgrw.f b/SRC/cla_herpvgrw.f new file mode 100644 index 00000000..3f331ee1 --- /dev/null +++ b/SRC/cla_herpvgrw.f @@ -0,0 +1,210 @@ + REAL FUNCTION CLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, + $ WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ) + REAL WORK( * ) +* .. +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + REAL AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER, LSAME + COMPLEX ZDUM +* .. +* .. External Functions .. + EXTERNAL LSAME, CLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, AIMAG, MAX, MIN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF (UPPER) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0 + DO I = 1, 2*N + WORK( I ) = 0.0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( CABS1( A( I,J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I,J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from csytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = + $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = + $ MAX( CABS1( AF( I, K+1 ) ) , WORK( K+1 ) ) + END DO + WORK(K) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + CLA_HERPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/cla_lin_berr.f b/SRC/cla_lin_berr.f new file mode 100644 index 00000000..b2a9702f --- /dev/null +++ b/SRC/cla_lin_berr.f @@ -0,0 +1,67 @@ + SUBROUTINE CLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NZ, NRHS +* .. +* .. Array Arguments .. + REAL AYB( N, NRHS ), BERR( NRHS ) + COMPLEX RES( N, NRHS ) +* +* CLA_LIN_BERR computes componentwise relative backward error from +* the formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* .. +* .. Local Scalars .. + REAL TMP + INTEGER I, J + COMPLEX CDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, AIMAG, MAX +* .. +* .. External Functions .. + EXTERNAL SLAMCH + REAL SLAMCH + REAL SAFE1 +* .. +* .. Statement Functions .. + COMPLEX CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Adding SAFE1 to the numerator guards against spuriously zero +* residuals. A similar safeguard is in the CLA_yyAMV routine used +* to compute AYB. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (NZ+1)*SAFE1 + + DO J = 1, NRHS + BERR(J) = 0.0 + DO I = 1, N + IF (AYB(I,J) .NE. 0.0) THEN + TMP = (SAFE1 + CABS1(RES(I,J)))/AYB(I,J) + BERR(J) = MAX( BERR(J), TMP ) + END IF +* +* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know +* the true residual also must be exactly 0.0. +* + END DO + END DO + END SUBROUTINE diff --git a/SRC/cla_porcond_c.f b/SRC/cla_porcond_c.f new file mode 100644 index 00000000..24b6be26 --- /dev/null +++ b/SRC/cla_porcond_c.f @@ -0,0 +1,194 @@ + REAL FUNCTION CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, + $ INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) + REAL C( * ), RWORK( * ) +* +* SLA_PORCOND_C Computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a REAL vector +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE + REAL AINVNM, ANORM, TMP + INTEGER I, J + LOGICAL UP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_PORCOND_C = 0.0E+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_PORCOND_C', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0E+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_PORCOND_C = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL CPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL CPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( UP ) THEN + CALL CPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL CPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_PORCOND_C = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_porcond_x.f b/SRC/cla_porcond_x.f new file mode 100644 index 00000000..036fd43c --- /dev/null +++ b/SRC/cla_porcond_x.f @@ -0,0 +1,168 @@ + REAL FUNCTION CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, X, INFO, + $ WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + REAL RWORK( * ) +* +* CLA_PORCOND_X Computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + REAL AINVNM, ANORM, TMP + LOGICAL UP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_PORCOND_X = 0.0E+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_PORCOND_X', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_PORCOND_X = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL CPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL CPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( UP ) THEN + CALL CPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL CPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_PORCOND_X = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_porfsx_extended.f b/SRC/cla_porfsx_extended.f new file mode 100644 index 00000000..25b073e4 --- /dev/null +++ b/SRC/cla_porfsx_extended.f @@ -0,0 +1,306 @@ + SUBROUTINE CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, COLEQU, C, B, LDB, Y, + $ LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE, + $ Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CCOPY, CPOTRS, CHEMV, BLAS_CHEMV_X, + $ BLAS_CHEMV2_X, CLA_SYAMV, CLA_WWADDW, + $ CLA_LIN_BERR, SLAMCH + REAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, AIMAG, MAX, MIN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL(N) * EPS + + IF (LSAME (UPLO, 'L')) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF (Y_PREC_STATE .EQ. EXTRA_Y) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + IF (Y_PREC_STATE .EQ. BASE_RESIDUAL) THEN + CALL CHEMV(UPLO, N, CMPLX(-1.0), A, LDA, Y(1,J), 1, + $ CMPLX(1.0), RES, 1) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_CHEMV_X(UPLO2, N, CMPLX(-1.0), A, LDA, + $ Y( 1, J ), 1, CMPLX(1.0), RES, 1, PREC_TYPE) + ELSE + CALL BLAS_CHEMV2_X(UPLO2, N, CMPLX(-1.0), A, LDA, + $ Y(1, J), Y_TAIL, 1, CMPLX(1.0), RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL CCOPY( N, RES, 1, DY, 1 ) + CALL CPOTRS( UPLO, N, NRHS, AF, LDAF, DY, N, INFO) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1(Y(I, J)) + DYK = CABS1(DY(I)) + + IF (YK .NE. 0.0) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF (DYK .NE. 0.0) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX(NORMX, YK * C(I)) + NORMDX = MAX(NORMDX, DYK * C(I)) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF (NORMX .NE. 0.0) THEN + DX_X = NORMDX / NORMX + ELSE IF (NORMDX .EQ. 0.0) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF (YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y) + $ INCR_PREC = .TRUE. + + IF (X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH) + $ X_STATE = WORKING_STATE + IF (X_STATE .EQ. WORKING_STATE) THEN + IF (DX_X .LE. EPS) THEN + X_STATE = CONV_STATE + ELSE IF (DXRAT .GT. RTHRESH) THEN + IF (Y_PREC_STATE .NE. EXTRA_Y) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF (DXRAT .GT. DXRATMAX) DXRATMAX = DXRAT + END IF + IF (X_STATE .GT. WORKING_STATE) FINAL_DX_X = DX_X + END IF + + IF (Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB) + $ Z_STATE = WORKING_STATE + IF (Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH) + $ Z_STATE = WORKING_STATE + IF (Z_STATE .EQ. WORKING_STATE) THEN + IF (DZ_Z .LE. EPS) THEN + Z_STATE = CONV_STATE + ELSE IF (DZ_Z .GT. DZ_UB) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF (DZRAT .GT. RTHRESH) THEN + IF (Y_PREC_STATE .NE. EXTRA_Y) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF (DZRAT .GT. DZRATMAX) DZRATMAX = DZRAT + END IF + IF (Z_STATE .GT. WORKING_STATE) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ (IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE) ) + $ GOTO 666 + + IF (INCR_PREC) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL CAXPY( N, CMPLX(1.0), DY, 1, Y(1,J), 1 ) + ELSE + CALL CLA_WWADDW(N, Y(1,J), Y_TAIL, DY) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF (X_STATE .EQ. WORKING_STATE) FINAL_DX_X = DX_X + IF (Z_STATE .EQ. WORKING_STATE) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL CHEMV(UPLO, N, CMPLX(-1.0), A, LDA, Y(1,J), 1, CMPLX(1.0), + $ RES, 1) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL CLA_SYAMV (UPLO2, N, 1.0, + $ A, LDA, Y(1, J), 1, 1.0, AYB, 1) + + CALL CLA_LIN_BERR (N, N, 1, RES, AYB, BERR_OUT(J)) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/cla_porpvgrw.f b/SRC/cla_porpvgrw.f new file mode 100644 index 00000000..e2a2eab6 --- /dev/null +++ b/SRC/cla_porpvgrw.f @@ -0,0 +1,113 @@ + REAL FUNCTION CLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ) + REAL WORK( * ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL AMAX, UMAX, RPVGRW + LOGICAL UPPER + COMPLEX ZDUM +* .. +* .. External Functions .. + EXTERNAL LSAME, CLASET + LOGICAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + UPPER = LSAME( 'Upper', UPLO ) +* +* SPOTRF will have factored only the NCOLSxNCOLS leading minor, so +* we restrict the growth search to that minor and use only the first +* 2*NCOLS workspace entries. +* + RPVGRW = 1.0 + DO I = 1, 2*NCOLS + WORK( I ) = 0.0 + END DO +* +* Find the max magnitude entry of each column. +* + IF ( UPPER ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( NCOLS+J ) = + $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( NCOLS+J ) = + $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of the factor in +* AF. No pivoting, so no permutations. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) + END DO + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + CLA_PORPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/cla_rpvgrw.f b/SRC/cla_rpvgrw.f new file mode 100644 index 00000000..9cec26d1 --- /dev/null +++ b/SRC/cla_rpvgrw.f @@ -0,0 +1,51 @@ + REAL FUNCTION CLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL AMAX, UMAX, RPVGRW + COMPLEX ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, ABS, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0 +* + DO J = 1, NCOLS + AMAX = 0.0 + UMAX = 0.0 + DO I = 1, N + AMAX = MAX( CABS1( A( I, J ) ), AMAX ) + END DO + DO I = 1, J + UMAX = MAX( CABS1( AF( I, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + CLA_RPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/cla_syamv.f b/SRC/cla_syamv.f new file mode 100644 index 00000000..412c5799 --- /dev/null +++ b/SRC/cla_syamv.f @@ -0,0 +1,284 @@ + SUBROUTINE CLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDA, N + INTEGER UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), X( * ) + REAL Y( * ) +* .. +* +* Purpose +* ======= +* +* CLA_SYAMV performs the matrix-vector operation +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* n by n symmetric matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* UPLO - INTEGER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = BLAS_UPPER Only the upper triangular part of A +* is to be referenced. +* +* UPLO = BLAS_LOWER Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - REAL . +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - COMPLEX array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - COMPLEX array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL . +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCY ) ) +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* -- Modified for the absolute-value product, April 2006 +* Jason Riedy, UC Berkeley +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY + COMPLEX ZDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'SSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of CLA_SYAMV +* + END diff --git a/SRC/cla_syrcond_c.f b/SRC/cla_syrcond_c.f new file mode 100644 index 00000000..7784a2d5 --- /dev/null +++ b/SRC/cla_syrcond_c.f @@ -0,0 +1,195 @@ + REAL FUNCTION CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, C, + $ CAPPLY, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ) + REAL C( * ), RWORK( * ) +* +* CLA_SYRCOND_C Computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a REAL vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE + REAL AINVNM, ANORM, TMP + INTEGER I, J + LOGICAL UP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_SYRCOND_C = 0.0E+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_SYRCOND_C', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0E+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF (I.GT.J) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_SYRCOND_C = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( UP ) THEN + CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_SYRCOND_C = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_syrcond_x.f b/SRC/cla_syrcond_x.f new file mode 100644 index 00000000..c98c1242 --- /dev/null +++ b/SRC/cla_syrcond_x.f @@ -0,0 +1,170 @@ + REAL FUNCTION CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, IPIV, X, + $ INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + REAL RWORK( * ) +* +* CLA_SYRCOND_X Computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX vector. +* WORK is a COMPLEX workspace of size 2*N, and +* RWORK is a REAL workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE + REAL AINVNM, ANORM, TMP + INTEGER I, J + LOGICAL UP + COMPLEX ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLACN2, CSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + CLA_SYRCOND_X = 0.0E+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CLA_SYRCOND_X', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0E+0 + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + CLA_SYRCOND_X = 1.0E+0 + RETURN + ELSE IF( ANORM .EQ. 0.0E+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0E+0 +* + KASE = 0 + 10 CONTINUE + CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( UP ) THEN + CALL CSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL CSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0E+0 ) + $ CLA_SYRCOND_X = 1.0E+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/cla_syrfsx_extended.f b/SRC/cla_syrfsx_extended.f new file mode 100644 index 00000000..afe76130 --- /dev/null +++ b/SRC/cla_syrfsx_extended.f @@ -0,0 +1,307 @@ + SUBROUTINE CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE, + $ Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CCOPY, CSYTRS, CSYMV, BLAS_CSYMV_X, + $ BLAS_CSYMV2_X, CLA_SYAMV, CLA_WWADDW, + $ CLA_LIN_BERR + REAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, AIMAG, MAX, MIN +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL CSYMV( UPLO, N, CMPLX(-1.0), A, LDA, Y(1,J), 1, + $ CMPLX(1.0), RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_CSYMV_X( UPLO2, N, CMPLX(-1.0), A, LDA, + $ Y( 1, J ), 1, CMPLX(1.0), RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_CSYMV2_X(UPLO2, N, CMPLX(-1.0), A, LDA, + $ Y(1, J), Y_TAIL, 1, CMPLX(1.0), RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL CCOPY( N, RES, 1, DY, 1 ) + CALL CSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF ( YK .NE. 0.0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF (DXRAT .GT. DXRATMAX) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL CAXPY( N, CMPLX(1.0), DY, 1, Y(1,J), 1 ) + ELSE + CALL CLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL CCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL CSYMV( UPLO, N, CMPLX(-1.0), A, LDA, Y(1,J), 1, + $ CMPLX(1.0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL CLA_SYAMV ( UPLO2, N, 1.0, + $ A, LDA, Y(1, J), 1, 1.0, AYB, 1 ) + + CALL CLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/cla_syrpvgrw.f b/SRC/cla_syrpvgrw.f new file mode 100644 index 00000000..84e71be9 --- /dev/null +++ b/SRC/cla_syrpvgrw.f @@ -0,0 +1,211 @@ + REAL FUNCTION CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, + $ WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ) + REAL WORK( * ) + INTEGER IPIV( * ) +* .. +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + REAL AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER + COMPLEX ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, AIMAG, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL LSAME, CLASET + LOGICAL LSAME +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL ( ZDUM ) ) + ABS( AIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF ( UPPER ) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0 + DO I = 1, 2*N + WORK( I ) = 0.0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from csytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = + $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = + $ MAX( CABS1( AF( I, K+1 ) ), WORK( K+1 ) ) + END DO + WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + CLA_SYRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/cla_wwaddw.f b/SRC/cla_wwaddw.f new file mode 100644 index 00000000..d0a7e88f --- /dev/null +++ b/SRC/cla_wwaddw.f @@ -0,0 +1,53 @@ + SUBROUTINE CLA_WWADDW( N, X, Y, W ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N +* .. +* .. Array Arguments .. + COMPLEX X( * ), Y( * ), W( * ) +* .. +* +* Purpose +* ======= +* +* CLA_WWADDW adds a vector W into a doubled-single vector (X, Y). +* +* This works for all extant IBM's hex and binary floating point +* arithmetics, but not for decimal. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The length of vectors X, Y, and W. +* +* X, Y (input/output) COMPLEX array, length N +* The doubled-single accumulation vector. +* +* W (input) COMPLEX array, length N +* The vector to be added. +* .. +* .. Local Scalars .. + COMPLEX S + INTEGER I +* .. +* .. Executable Statements .. +* + DO 10 I = 1, N + S = X(I) + W(I) + S = (S + S) - S + Y(I) = ((X(I) - S) + W(I)) + Y(I) + X(I) = S + 10 CONTINUE + RETURN + END diff --git a/SRC/clabrd.f b/SRC/clabrd.f index fd656f98..2053b86f 100644 --- a/SRC/clabrd.f +++ b/SRC/clabrd.f @@ -1,7 +1,7 @@ SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacgv.f b/SRC/clacgv.f index 342d1790..6a634d27 100644 --- a/SRC/clacgv.f +++ b/SRC/clacgv.f @@ -1,6 +1,6 @@ SUBROUTINE CLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacn2.f b/SRC/clacn2.f index 319833ba..8fb1fd00 100755..100644 --- a/SRC/clacn2.f +++ b/SRC/clacn2.f @@ -1,6 +1,6 @@ SUBROUTINE CLACN2( N, V, X, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacon.f b/SRC/clacon.f index 2228701d..8e648864 100644 --- a/SRC/clacon.f +++ b/SRC/clacon.f @@ -1,6 +1,6 @@ SUBROUTINE CLACON( N, V, X, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacp2.f b/SRC/clacp2.f index 0cacd194..ea6c01a6 100644 --- a/SRC/clacp2.f +++ b/SRC/clacp2.f @@ -1,6 +1,6 @@ SUBROUTINE CLACP2( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacpy.f b/SRC/clacpy.f index 4af4a78f..7a24cbd2 100644 --- a/SRC/clacpy.f +++ b/SRC/clacpy.f @@ -1,6 +1,6 @@ SUBROUTINE CLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacrm.f b/SRC/clacrm.f index 804f97f1..c917194b 100644 --- a/SRC/clacrm.f +++ b/SRC/clacrm.f @@ -1,6 +1,6 @@ SUBROUTINE CLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clacrt.f b/SRC/clacrt.f index 71f6203d..f41477e8 100644 --- a/SRC/clacrt.f +++ b/SRC/clacrt.f @@ -1,6 +1,6 @@ SUBROUTINE CLACRT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cladiv.f b/SRC/cladiv.f index 9819faa5..202abe9f 100644 --- a/SRC/cladiv.f +++ b/SRC/cladiv.f @@ -1,6 +1,6 @@ COMPLEX FUNCTION CLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claed0.f b/SRC/claed0.f index f3c609c8..2b0ace6a 100644 --- a/SRC/claed0.f +++ b/SRC/claed0.f @@ -1,7 +1,7 @@ SUBROUTINE CLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claed7.f b/SRC/claed7.f index 819fb023..3583f8ce 100644 --- a/SRC/claed7.f +++ b/SRC/claed7.f @@ -3,7 +3,7 @@ $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claed8.f b/SRC/claed8.f index 69047298..50a46eec 100644 --- a/SRC/claed8.f +++ b/SRC/claed8.f @@ -2,7 +2,7 @@ $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, $ GIVCOL, GIVNUM, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claein.f b/SRC/claein.f index 97b19b02..17ed3c33 100644 --- a/SRC/claein.f +++ b/SRC/claein.f @@ -1,7 +1,7 @@ SUBROUTINE CLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, $ EPS3, SMLNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claesy.f b/SRC/claesy.f index 257752f5..52fc1615 100644 --- a/SRC/claesy.f +++ b/SRC/claesy.f @@ -1,6 +1,6 @@ SUBROUTINE CLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claev2.f b/SRC/claev2.f index aca90fcb..3a59cbd9 100644 --- a/SRC/claev2.f +++ b/SRC/claev2.f @@ -1,6 +1,6 @@ SUBROUTINE CLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clag2z.f b/SRC/clag2z.f index a2fdbda3..b2fbef38 100644 --- a/SRC/clag2z.f +++ b/SRC/clag2z.f @@ -1,35 +1,28 @@ - SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO) + SUBROUTINE CLAG2Z( M, N, SA, LDSA, A, LDA, INFO ) * -* -- LAPACK PROTOTYPE auxilary routine (version 3.1.1) -- +* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* January 2007 -* -* .. -* .. WARNING: PROTOTYPE .. -* This is an LAPACK PROTOTYPE routine which means that the -* interface of this routine is likely to be changed in the future -* based on community feedback. +* August 2007 * * .. * .. Scalar Arguments .. - INTEGER INFO,LDA,LDSA,M,N + INTEGER INFO, LDA, LDSA, M, N * .. * .. Array Arguments .. - COMPLEX SA(LDSA,*) - COMPLEX*16 A(LDA,*) + COMPLEX SA( LDSA, * ) + COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * -* CLAG2Z converts a COMPLEX SINGLE PRECISION matrix, SA, to a COMPLEX -* DOUBLE PRECISION matrix, A. +* CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A. * -* Note that while it is possible to overflow while converting +* Note that while it is possible to overflow while converting * from double to single, it is not possible to overflow when -* converting from single to double. +* converting from single to double. * -* This is a helper routine so there is no argument checking. +* This is an auxiliary routine so there is no argument checking. * * Arguments * ========= @@ -40,14 +33,14 @@ * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * -* SA (output) REAL array, dimension (LDSA,N) -* On exit, the M-by-N coefficient matrix SA. +* SA (input) COMPLEX array, dimension (LDSA,N) +* On entry, the M-by-N coefficient matrix SA. * * LDSA (input) INTEGER * The leading dimension of the array SA. LDSA >= max(1,M). * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N coefficient matrix A. +* A (output) COMPLEX*16 array, dimension (LDA,N) +* On exit, the M-by-N coefficient matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). @@ -57,15 +50,15 @@ * ========= * * .. Local Scalars .. - INTEGER I,J + INTEGER I, J * .. * .. Executable Statements .. * INFO = 0 - DO 20 J = 1,N - DO 30 I = 1,M - A(I,J) = SA(I,J) - 30 CONTINUE + DO 20 J = 1, N + DO 10 I = 1, M + A( I, J ) = SA( I, J ) + 10 CONTINUE 20 CONTINUE RETURN * diff --git a/SRC/clags2.f b/SRC/clags2.f index d926d61b..a63a4f03 100644 --- a/SRC/clags2.f +++ b/SRC/clags2.f @@ -1,7 +1,7 @@ SUBROUTINE CLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clagtm.f b/SRC/clagtm.f index 8723b258..f07a6208 100644 --- a/SRC/clagtm.f +++ b/SRC/clagtm.f @@ -1,7 +1,7 @@ SUBROUTINE CLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clahef.f b/SRC/clahef.f index 6c069d70..ce7dfb09 100644 --- a/SRC/clahef.f +++ b/SRC/clahef.f @@ -1,6 +1,6 @@ SUBROUTINE CLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clahqr.f b/SRC/clahqr.f index 5541ec8a..b3549527 100644 --- a/SRC/clahqr.f +++ b/SRC/clahqr.f @@ -1,8 +1,8 @@ SUBROUTINE CLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -110,11 +110,10 @@ * * 12-04 Further modifications by * Ralph Byers, University of Kansas, USA -* -* This is a modified version of CLAHQR from LAPACK version 3.0. -* It is (1) more robust against overflow and underflow and -* (2) adopts the more conservative Ahues & Tisseur stopping -* criterion (LAWN 122, 1997). +* This is a modified version of CLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). * * ========================================================= * @@ -177,6 +176,13 @@ IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * ==== ensure that subdiagonal entries are real ==== + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF DO 20 I = ILO + 1, IHI IF( AIMAG( H( I, I-1 ) ).NE.RZERO ) THEN * ==== The following redundant normalization @@ -185,13 +191,6 @@ SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) SC = CONJG( SC ) / ABS( SC ) H( I, I-1 ) = ABS( H( I, I-1 ) ) - IF( WANTT ) THEN - JLO = 1 - JHI = N - ELSE - JLO = ILO - JHI = IHI - END IF CALL CSCAL( JHI-I+1, SC, H( I, I ), LDH ) CALL CSCAL( MIN( JHI, I+1 )-JLO+1, CONJG( SC ), H( JLO, I ), $ 1 ) @@ -289,7 +288,13 @@ I2 = I END IF * - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN + IF( ITS.EQ.10 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( REAL( H( L+1, L ) ) ) + T = S + H( L, L ) + ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * @@ -326,13 +331,13 @@ H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T - H21 = H( M+1, M ) + H21 = REAL( H( M+1, M ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 - H10 = H( M, M-1 ) + H10 = REAL( H( M, M-1 ) ) IF( ABS( H10 )*ABS( H21 ).LE.ULP* $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) $ GO TO 70 @@ -340,7 +345,7 @@ H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T - H21 = H( L+1, L ) + H21 = REAL( H( L+1, L ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S diff --git a/SRC/clahr2.f b/SRC/clahr2.f index fcb49212..3e97d3d5 100644 --- a/SRC/clahr2.f +++ b/SRC/clahr2.f @@ -1,6 +1,6 @@ SUBROUTINE CLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clahrd.f b/SRC/clahrd.f index f8252e8b..48a2b01b 100644 --- a/SRC/clahrd.f +++ b/SRC/clahrd.f @@ -1,6 +1,6 @@ SUBROUTINE CLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claic1.f b/SRC/claic1.f index a19ccb79..f2e4f6f6 100644 --- a/SRC/claic1.f +++ b/SRC/claic1.f @@ -1,6 +1,6 @@ SUBROUTINE CLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clals0.f b/SRC/clals0.f index 4786ea71..4a3f728c 100644 --- a/SRC/clals0.f +++ b/SRC/clals0.f @@ -2,7 +2,7 @@ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clalsa.f b/SRC/clalsa.f index 8938fac1..56182ce2 100644 --- a/SRC/clalsa.f +++ b/SRC/clalsa.f @@ -3,7 +3,7 @@ $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clalsd.f b/SRC/clalsd.f index 01b7a31c..6ef18299 100644 --- a/SRC/clalsd.f +++ b/SRC/clalsd.f @@ -1,7 +1,7 @@ SUBROUTINE CLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, RWORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clangb.f b/SRC/clangb.f index 78210843..0e43f01b 100644 --- a/SRC/clangb.f +++ b/SRC/clangb.f @@ -1,7 +1,7 @@ REAL FUNCTION CLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clange.f b/SRC/clange.f index a08ec756..49bd8337 100644 --- a/SRC/clange.f +++ b/SRC/clange.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clangt.f b/SRC/clangt.f index 4e2e1ceb..8a773d8a 100644 --- a/SRC/clangt.f +++ b/SRC/clangt.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clanhb.f b/SRC/clanhb.f index 842228e8..d0c75c68 100644 --- a/SRC/clanhb.f +++ b/SRC/clanhb.f @@ -1,7 +1,7 @@ REAL FUNCTION CLANHB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clanhe.f b/SRC/clanhe.f index 02155632..3afaa67d 100644 --- a/SRC/clanhe.f +++ b/SRC/clanhe.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clanhf.f b/SRC/clanhf.f new file mode 100644 index 00000000..a89474e5 --- /dev/null +++ b/SRC/clanhf.f @@ -0,0 +1,1358 @@ + REAL FUNCTION CLANHF( NORM, TRANSR, UPLO, N, A, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM, TRANSR, UPLO + INTEGER N +* .. +* .. Array Arguments .. + REAL WORK( 0: * ) + COMPLEX A( 0: * ) +* .. +* +* Purpose +* ======= +* +* CLANHF returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* complex Hermitian matrix A in RFP format. +* +* Description +* =========== +* +* CLANHF returns the value +* +* CLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER +* Specifies the value to be returned in CLANHF as described +* above. +* +* TRANSR (input) CHARACTER +* Specifies whether the RFP format of A is normal or +* conjugate-transposed format. +* = 'N': RFP format is Normal +* = 'C': RFP format is Conjugate-transposed +* +* UPLO (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' RFP A came from an upper triangular +* matrix +* +* UPLO = 'L' or 'l' RFP A came from a lower triangular +* matrix +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, CLANHF is +* set to zero. +* +* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); +* On entry, the matrix A in RFP Format. +* RFP Format is described by TRANSR, UPLO and N as follows: +* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A +* as defined when TRANSR = 'N'. The contents of RFP A are +* defined by UPLO as follows: If UPLO = 'U' the RFP A +* contains the ( N*(N+1)/2 ) elements of upper packed A +* either in normal or conjugate-transpose Format. If +* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements +* of lower packed A either in normal or conjugate-transpose +* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When +* TRANSR is 'N' the LDA is N+1 when N is even and is N when +* is odd. See the Note below for more details. +* Unchanged on exit. +* +* WORK (workspace) REAL array, dimension (LWORK), +* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +* WORK is not referenced. +* +* Note: +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA + REAL SCALE, S, VALUE, AA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + EXTERNAL LSAME, ISAMAX +* .. +* .. External Subroutines .. + EXTERNAL CLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + CLANHF = ZERO + RETURN + END IF +* +* set noe = 1 if n is odd. if n is even set noe=0 +* + NOE = 1 + IF( MOD( N, 2 ).EQ.0 ) + + NOE = 0 +* +* set ifm = 0 when form='C' or 'c' and 1 otherwise +* + IFM = 1 + IF( LSAME( TRANSR, 'C' ) ) + + IFM = 0 +* +* set ilu = 0 when uplo='U or 'u' and 1 otherwise +* + ILU = 1 + IF( LSAME( UPLO, 'U' ) ) + + ILU = 0 +* +* set lda = (n+1)/2 when ifm = 0 +* set lda = n when ifm = 1 and noe = 1 +* set lda = n+1 when ifm = 1 and noe = 0 +* + IF( IFM.EQ.1 ) THEN + IF( NOE.EQ.1 ) THEN + LDA = N + ELSE +* noe=0 + LDA = N + 1 + END IF + ELSE +* ifm=0 + LDA = ( N+1 ) / 2 + END IF +* + IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + K = ( N+1 ) / 2 + VALUE = ZERO + IF( NOE.EQ.1 ) THEN +* n is odd & n = k + k - 1 + IF( IFM.EQ.1 ) THEN +* A is n by k + IF( ILU.EQ.1 ) THEN +* uplo ='L' + J = 0 +* -> L(0,0) + VALUE = MAX( VALUE, ABS( REAL( A( J+J*LDA ) ) ) ) + DO I = 1, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = 1, K - 1 + DO I = 0, J - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - 1 +* L(k+j,k+j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = J +* -> L(j,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = J + 1, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 2 + DO I = 0, K + J - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K + J - 1 +* -> U(i,i) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = I + 1 +* =k+j; i -> U(j,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = K + J + 1, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + DO I = 0, N - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) +* j=k-1 + END DO +* i=n-1 -> U(n-1,n-1) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + END IF + ELSE +* xpose case; A is k by n + IF( ILU.EQ.1 ) THEN +* uplo ='L' + DO J = 0, K - 2 + DO I = 0, J - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J +* L(i,i) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = J + 1 +* L(j+k,j+k) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = J + 2, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K - 1 + DO I = 0, K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K - 1 +* -> L(i,i) is at A(i,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO J = K, N - 1 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 2 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K - 1 +* -> U(j,j) is at A(0,j) + VALUE = MAX( VALUE, ABS( REAL( A( 0+J*LDA ) ) ) ) + DO I = 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = K, N - 1 + DO I = 0, J - K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - K +* -> U(i,i) at A(i,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = J - K + 1 +* U(j,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = J - K + 2, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + END IF + END IF + ELSE +* n is even & k = n/2 + IF( IFM.EQ.1 ) THEN +* A is n+1 by k + IF( ILU.EQ.1 ) THEN +* uplo ='L' + J = 0 +* -> L(k,k) & j=1 -> L(0,0) + VALUE = MAX( VALUE, ABS( REAL( A( J+J*LDA ) ) ) ) + VALUE = MAX( VALUE, ABS( REAL( A( J+1+J*LDA ) ) ) ) + DO I = 2, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = 1, K - 1 + DO I = 0, J - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J +* L(k+j,k+j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = J + 1 +* -> L(j,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = J + 2, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 2 + DO I = 0, K + J - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K + J +* -> U(i,i) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = I + 1 +* =k+j+1; i -> U(j,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = K + J + 2, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + DO I = 0, N - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) +* j=k-1 + END DO +* i=n-1 -> U(n-1,n-1) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = N +* -> U(k-1,k-1) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + END IF + ELSE +* xpose case; A is k by n+1 + IF( ILU.EQ.1 ) THEN +* uplo ='L' + J = 0 +* -> L(k,k) at A(0,0) + VALUE = MAX( VALUE, ABS( REAL( A( J+J*LDA ) ) ) ) + DO I = 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = 1, K - 1 + DO I = 0, J - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - 1 +* L(i,i) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = J +* L(j+k,j+k) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = J + 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K + DO I = 0, K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K - 1 +* -> L(i,i) is at A(i,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO J = K + 1, N + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 1 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K +* -> U(j,j) is at A(0,j) + VALUE = MAX( VALUE, ABS( REAL( A( 0+J*LDA ) ) ) ) + DO I = 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = K + 1, N - 1 + DO I = 0, J - K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - K - 1 +* -> U(i,i) at A(i,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + I = J - K +* U(j,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + DO I = J - K + 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = N + DO I = 0, K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K - 1 +* U(k,k) at A(i,j) + VALUE = MAX( VALUE, ABS( REAL( A( I+J*LDA ) ) ) ) + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + + ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is Hermitian). +* + IF( IFM.EQ.1 ) THEN +* A is 'N' + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd & A is n by (n+1)/2 + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + IF( I.EQ.K+K ) + + GO TO 10 + I = I + 1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + 10 CONTINUE + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 & uplo = 'L' + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + IF( J.GT.0 ) THEN + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + END IF + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even & A is n+1 by k = n/2 + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + I = I + 1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 & uplo = 'L' + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + ELSE +* ifm=0 + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd & A is (n+1)/2 by n + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + N1 = K +* n/2 + K = K + 1 +* k is the row size and lda + DO I = N1, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, N1 - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,n1+i) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=n1=k-1 is special + S = ABS( REAL( A( 0+J*LDA ) ) ) +* A(k-1,k-1) + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,i+n1) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K, N - 1 + S = ZERO + DO I = 0, J - K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-k + AA = ABS( REAL( A( I+J*LDA ) ) ) +* A(j-k,j-k) + S = S + AA + WORK( J-K ) = WORK( J-K ) + S + I = I + 1 + S = ABS( REAL( A( I+J*LDA ) ) ) +* A(j,j) + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 & uplo = 'L' + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 2 +* process + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( REAL( A( I+J*LDA ) ) ) +* i=j so process of A(j,j) + S = S + AA + WORK( J ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( REAL( A( I+J*LDA ) ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k-1 is special :process col A(k-1,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K, N - 1 +* process col j of A = A(j,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even & A is k=n/2 by n+1 + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i+k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=k + AA = ABS( REAL( A( 0+J*LDA ) ) ) +* A(k,k) + S = AA + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k,k+i) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K + 1, N - 1 + S = ZERO + DO I = 0, J - 2 - K + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-1-k + AA = ABS( REAL( A( I+J*LDA ) ) ) +* A(j-k-1,j-k-1) + S = S + AA + WORK( J-K-1 ) = WORK( J-K-1 ) + S + I = I + 1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* A(j,j) + S = AA + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO +* j=n + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(i,k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = WORK( I ) + S + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 & uplo = 'L' + DO I = K, N - 1 + WORK( I ) = ZERO + END DO +* j=0 is special :process col A(k:n-1,k) + S = ABS( REAL( A( 0 ) ) ) +* A(k,k) + DO I = 1, K - 1 + AA = ABS( A( I ) ) +* A(k+i,k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( K ) = WORK( K ) + S + DO J = 1, K - 1 +* process + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( REAL( A( I+J*LDA ) ) ) +* i=j-1 so process of A(j-1,j-1) + S = S + AA + WORK( J-1 ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( REAL( A( I+J*LDA ) ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k is special :process col A(k,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* +* i=k-1 + AA = ABS( REAL( A( I+J*LDA ) ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K + 1, N +* +* process col j-1 of A = A(j-1,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J-1 ) = WORK( J-1 ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + K = ( N+1 ) / 2 + SCALE = ZERO + S = ONE + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is normal & A is n by k + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 3 + CALL CLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) +* L at A(k,0) + END DO + DO J = 0, K - 1 + CALL CLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = K - 1 +* -> U(k,k) at A(k-1,0) + DO I = 0, K - 2 + AA = REAL( A( L ) ) +* U(k+i,k+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* U(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + AA = REAL( A( L ) ) +* U(n-1,n-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL CLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* trap L at A(0,0) + END DO + DO J = 1, K - 2 + CALL CLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + S = S + S +* double s for the off diagonal elements + AA = REAL( A( 0 ) ) +* L(0,0) at A(0,0) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = LDA +* -> L(k,k) at A(0,1) + DO I = 1, K - 1 + AA = REAL( A( L ) ) +* L(k-1+i,k-1+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + END IF + ELSE +* A is xpose & A is k by n + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 2 + CALL CLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) +* U at A(0,k) + END DO + DO J = 0, K - 2 + CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL CLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, + + SCALE, S ) +* L at A(0,k-1) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 + K*LDA - LDA +* -> U(k-1,k-1) at A(0,k-1) + AA = REAL( A( L ) ) +* U(k-1,k-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA +* -> U(0,0) at A(0,k) + DO J = K, N - 1 + AA = REAL( A( L ) ) +* -> U(j-k,j-k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* -> U(j,j) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + ELSE +* A' is lower + DO J = 1, K - 1 + CALL CLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + DO J = K, N - 1 + CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,k) + END DO + DO J = 0, K - 3 + CALL CLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) +* L at A(1,0) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 +* -> L(0,0) at A(0,0) + DO I = 0, K - 2 + AA = REAL( A( L ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* L(k+i,k+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO +* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1) + AA = REAL( A( L ) ) +* L(k-1,k-1) at A(k-1,k-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + END IF + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 2 + CALL CLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) +* L at A(k+1,0) + END DO + DO J = 0, K - 1 + CALL CLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = K +* -> U(k,k) at A(k,0) + DO I = 0, K - 1 + AA = REAL( A( L ) ) +* U(k+i,k+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* U(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL CLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) +* trap L at A(1,0) + END DO + DO J = 1, K - 1 + CALL CLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 +* -> L(k,k) at A(0,0) + DO I = 0, K - 1 + AA = REAL( A( L ) ) +* L(k-1+i,k-1+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 1 + CALL CLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) +* U at A(0,k+1) + END DO + DO J = 0, K - 1 + CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL CLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, + + S ) +* L at A(0,k) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 + K*LDA +* -> U(k,k) at A(0,k) + AA = REAL( A( L ) ) +* U(k,k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA +* -> U(0,0) at A(0,k+1) + DO J = K + 1, N - 1 + AA = REAL( A( L ) ) +* -> U(j-k-1,j-k-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* -> U(j,j) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO +* L=k-1+n*lda +* -> U(k-1,k-1) at A(k-1,n) + AA = REAL( A( L ) ) +* U(k,k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + ELSE +* A' is lower + DO J = 1, K - 1 + CALL CLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + DO J = K + 1, N + CALL CLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,k+1) + END DO + DO J = 0, K - 2 + CALL CLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* L at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 +* -> L(k,k) at A(0,0) + AA = REAL( A( L ) ) +* L(k,k) at A(0,0) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = LDA +* -> L(0,0) at A(0,1) + DO I = 0, K - 2 + AA = REAL( A( L ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = REAL( A( L+1 ) ) +* L(k+i+1,k+i+1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO +* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k) + AA = REAL( A( L ) ) +* L(k-1,k-1) at A(k-1,k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + END IF + END IF + END IF + VALUE = SCALE*SQRT( S ) + END IF +* + CLANHF = VALUE + RETURN +* +* End of CLANHF +* + END diff --git a/SRC/clanhp.f b/SRC/clanhp.f index e4aca0bd..1d591034 100644 --- a/SRC/clanhp.f +++ b/SRC/clanhp.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANHP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clanhs.f b/SRC/clanhs.f index 60d9d4d3..133f8d4f 100644 --- a/SRC/clanhs.f +++ b/SRC/clanhs.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clanht.f b/SRC/clanht.f index 7ae6cfda..444a0681 100644 --- a/SRC/clanht.f +++ b/SRC/clanht.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANHT( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clansb.f b/SRC/clansb.f index bb5e096a..2855d5cf 100644 --- a/SRC/clansb.f +++ b/SRC/clansb.f @@ -1,7 +1,7 @@ REAL FUNCTION CLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clansp.f b/SRC/clansp.f index dccc0bf3..816eb7e3 100644 --- a/SRC/clansp.f +++ b/SRC/clansp.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clansy.f b/SRC/clansy.f index d8d5343a..a11f9412 100644 --- a/SRC/clansy.f +++ b/SRC/clansy.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clantb.f b/SRC/clantb.f index f2f52e75..2ad6cba9 100644 --- a/SRC/clantb.f +++ b/SRC/clantb.f @@ -1,7 +1,7 @@ REAL FUNCTION CLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clantp.f b/SRC/clantp.f index 02ac9e70..e41fa1aa 100644 --- a/SRC/clantp.f +++ b/SRC/clantp.f @@ -1,6 +1,6 @@ REAL FUNCTION CLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clantr.f b/SRC/clantr.f index f644d628..d3ed29af 100644 --- a/SRC/clantr.f +++ b/SRC/clantr.f @@ -1,7 +1,7 @@ REAL FUNCTION CLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clapll.f b/SRC/clapll.f index 2934d62a..90068921 100644 --- a/SRC/clapll.f +++ b/SRC/clapll.f @@ -1,6 +1,6 @@ SUBROUTINE CLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clapmt.f b/SRC/clapmt.f index 94d0eb2a..0749be0e 100644 --- a/SRC/clapmt.f +++ b/SRC/clapmt.f @@ -1,6 +1,6 @@ SUBROUTINE CLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqgb.f b/SRC/claqgb.f index 9eac07ee..50558447 100644 --- a/SRC/claqgb.f +++ b/SRC/claqgb.f @@ -1,7 +1,7 @@ SUBROUTINE CLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqge.f b/SRC/claqge.f index 0dbca676..587ffc0f 100644 --- a/SRC/claqge.f +++ b/SRC/claqge.f @@ -1,7 +1,7 @@ SUBROUTINE CLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqhb.f b/SRC/claqhb.f index 43b22a86..ec9c35ed 100644 --- a/SRC/claqhb.f +++ b/SRC/claqhb.f @@ -1,6 +1,6 @@ SUBROUTINE CLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqhe.f b/SRC/claqhe.f index 6309a9b8..e489793f 100644 --- a/SRC/claqhe.f +++ b/SRC/claqhe.f @@ -1,6 +1,6 @@ SUBROUTINE CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqhp.f b/SRC/claqhp.f index 4abf1b06..f5a878f0 100644 --- a/SRC/claqhp.f +++ b/SRC/claqhp.f @@ -1,6 +1,6 @@ SUBROUTINE CLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqp2.f b/SRC/claqp2.f index 3e012a71..fca409a9 100644 --- a/SRC/claqp2.f +++ b/SRC/claqp2.f @@ -1,7 +1,7 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqps.f b/SRC/claqps.f index 5d0e6c04..1cf2bc2b 100644 --- a/SRC/claqps.f +++ b/SRC/claqps.f @@ -1,7 +1,7 @@ SUBROUTINE CLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqr0.f b/SRC/claqr0.f index e93f5749..4ea7417b 100644 --- a/SRC/claqr0.f +++ b/SRC/claqr0.f @@ -1,8 +1,8 @@ SUBROUTINE CLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -156,20 +156,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . CLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== REAL WILK1 PARAMETER ( WILK1 = 0.75e0 ) COMPLEX ZERO, ONE @@ -183,9 +186,9 @@ REAL S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -218,24 +221,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use CLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use CLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -250,6 +238,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -259,7 +260,6 @@ NWR = ILAENV( 13, 'CLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -310,6 +310,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -348,50 +349,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. - $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/claqr1.f b/SRC/claqr1.f index c491268f..c51bcb67 100644 --- a/SRC/claqr1.f +++ b/SRC/claqr1.f @@ -1,7 +1,7 @@ SUBROUTINE CLAQR1( N, H, LDH, S1, S2, V ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -54,8 +54,8 @@ PARAMETER ( RZERO = 0.0e0 ) * .. * .. Local Scalars .. - COMPLEX CDUM - REAL H21S, H31S, S + COMPLEX CDUM, H21S, H31S + REAL S * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, REAL diff --git a/SRC/claqr2.f b/SRC/claqr2.f index 2bdea99a..4b980bb1 100644 --- a/SRC/claqr2.f +++ b/SRC/claqr2.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -81,7 +81,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) COMPLEX array, dimension (LDZ,IHI) +* Z (input/output) COMPLEX array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the unitary * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -152,7 +152,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), @@ -172,7 +172,7 @@ * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLARF, - $ CLARFG, CLASET, CTREXC, CUNGHR, SLABAD + $ CLARFG, CLASET, CTREXC, CUNMHR, SLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL @@ -197,9 +197,10 @@ CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to CUNGHR ==== +* ==== Workspace query call to CUNMHR ==== * - CALL CUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== @@ -218,6 +219,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -251,12 +253,12 @@ ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN - NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -292,7 +294,7 @@ NS = NS - 1 ELSE * -* ==== One undflatable eigenvalue. Move it up out of the +* ==== One undeflatable eigenvalue. Move it up out of the * . way. (CTREXC can not fail in this case.) ==== * IFST = NS @@ -365,18 +367,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of CUNGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL CUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL CGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL CLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/claqr3.f b/SRC/claqr3.f index 7fbcdb4d..f69ae2f2 100644 --- a/SRC/claqr3.f +++ b/SRC/claqr3.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -77,7 +77,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) COMPLEX array, dimension (LDZ,IHI) +* Z (input/output) COMPLEX array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the unitary * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -148,7 +148,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), @@ -170,7 +170,7 @@ * .. * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4, - $ CLARF, CLARFG, CLASET, CTREXC, CUNGHR, SLABAD + $ CLARF, CLARFG, CLASET, CTREXC, CUNMHR, SLABAD * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL @@ -195,9 +195,10 @@ CALL CGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to CUNGHR ==== +* ==== Workspace query call to CUNMHR ==== * - CALL CUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to CLAQR4 ==== @@ -222,6 +223,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -255,12 +257,12 @@ ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN - NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -302,7 +304,7 @@ NS = NS - 1 ELSE * -* ==== One undflatable eigenvalue. Move it up out of the +* ==== One undeflatable eigenvalue. Move it up out of the * . way. (CTREXC can not fail in this case.) ==== * IFST = NS @@ -375,18 +377,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of CUNGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL CUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL CGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL CLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/claqr4.f b/SRC/claqr4.f index 7e4fe4d7..7d4282e4 100644 --- a/SRC/claqr4.f +++ b/SRC/claqr4.f @@ -1,8 +1,8 @@ SUBROUTINE CLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -163,20 +163,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . CLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== REAL WILK1 PARAMETER ( WILK1 = 0.75e0 ) COMPLEX ZERO, ONE @@ -190,9 +193,9 @@ REAL S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -225,24 +228,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use CLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use CLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -257,6 +245,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -266,7 +267,6 @@ NWR = ILAENV( 13, 'CLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -317,6 +317,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -355,50 +356,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. - $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/claqr5.f b/SRC/claqr5.f index 0fb2bbd3..c7b00f7d 100644 --- a/SRC/claqr5.f +++ b/SRC/claqr5.f @@ -2,8 +2,8 @@ $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, $ WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -57,9 +57,9 @@ * NSHFTS gives the number of simultaneous shifts. NSHFTS * must be positive and even. * -* S (input) COMPLEX array of size (NSHFTS) +* S (input/output) COMPLEX array of size (NSHFTS) * S contains the shifts of origin that define the multi- -* shift QR sweep. +* shift QR sweep. On output S may be reordered. * * H (input/output) COMPLEX array of size (LDH,N) * On input H contains a Hessenberg matrix. On output a @@ -120,13 +120,12 @@ * LDWV is the leading dimension of WV as declared in the * in the calling subroutine. LDWV.GE.NV. * -* * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ============================================================ +* ================================================================ * Reference: * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR @@ -134,7 +133,7 @@ * Level 3 Performance, SIAM Journal of Matrix Analysis, * volume 23, pages 929--947, 2002. * -* ============================================================ +* ================================================================ * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0e0, 0.0e0 ), @@ -186,7 +185,7 @@ IF( KTOP.GE.KBOT ) $ RETURN * -* ==== NSHFTS is supposed to be even, but if is odd, +* ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) @@ -272,19 +271,12 @@ CALL CLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant -* . deflation or destructive underflow. (The -* . initial bulge is always collapsed.) Use -* . the two-small-subdiagonals trick to try -* . to get it started again. If V(2,M).NE.0 and -* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then -* . this bulge is collapsing into a zero -* . subdiagonal. It will be restarted next -* . trip through the loop.) -* - IF( V( 1, M ).NE.ZERO .AND. - $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, - $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) - $ THEN +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * @@ -294,46 +286,31 @@ ELSE * * ==== Atypical case: collapsed. Attempt to -* . reintroduce ignoring H(K+1,K). If the -* . fill resulting from the new reflector -* . is too large, then abandon it. +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL CLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), $ S( 2*M ), VT ) - SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + - $ CABS1( VT( 3 ) ) - IF( SCL.NE.RZERO ) THEN - VT( 1 ) = VT( 1 ) / SCL - VT( 2 ) = VT( 2 ) / SCL - VT( 3 ) = VT( 3 ) / SCL - END IF + ALPHA = VT( 1 ) + CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = CONJG( VT( 1 ) )* + $ ( H( K+1, K )+CONJG( VT( 2 ) )* + $ H( K+2, K ) ) * -* ==== The following is the traditional and -* . conservative two-small-subdiagonals -* . test. ==== -* . - IF( CABS1( H( K+1, K ) )* - $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* - $ CABS1( VT( 1 ) )*( CABS1( H( K, - $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, - $ K+2 ) ) ) ) THEN + IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* + $ ( CABS1( H( K, K ) )+CABS1( H( K+1, + $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would -* . create non-negligible fill. If -* . the old reflector is diagonal (only -* . possible with underflows), then -* . change it to I. Otherwise, use -* . it with trepidation. ==== -* - IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) - $ THEN - V( 1, M ) = ZERO - ELSE - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - END IF +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would @@ -341,13 +318,7 @@ * . Replace the old reflector with * . the new one. ==== * - ALPHA = VT( 1 ) - CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = H( K+1, K ) + - $ H( K+2, K )*CONJG( VT( 2 ) ) + - $ H( K+3, K )*CONJG( VT( 3 ) ) - H( K+1, K ) = H( K+1, K ) - - $ CONJG( VT( 1 ) )*REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) @@ -374,12 +345,6 @@ H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF - ELSE -* -* ==== Initialize V(1,M22) here to avoid possible undefined -* . variable problems later. ==== -* - V( 1, M22 ) = ZERO END IF * * ==== Multiply H by reflections from the left ==== @@ -679,7 +644,7 @@ CALL CGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * -* ==== Copy top of H bottom of WH ==== +* ==== Copy top of H to bottom of WH ==== * CALL CLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) diff --git a/SRC/claqsb.f b/SRC/claqsb.f index 0ac7e6a4..c4c5ef17 100644 --- a/SRC/claqsb.f +++ b/SRC/claqsb.f @@ -1,6 +1,6 @@ SUBROUTINE CLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqsp.f b/SRC/claqsp.f index 98d0682c..b02cf4b4 100644 --- a/SRC/claqsp.f +++ b/SRC/claqsp.f @@ -1,6 +1,6 @@ SUBROUTINE CLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claqsy.f b/SRC/claqsy.f index bc8146fe..85ce4656 100644 --- a/SRC/claqsy.f +++ b/SRC/claqsy.f @@ -1,6 +1,6 @@ SUBROUTINE CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clar1v.f b/SRC/clar1v.f index 69f37db6..55f5f4a0 100644 --- a/SRC/clar1v.f +++ b/SRC/clar1v.f @@ -2,7 +2,7 @@ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clar2v.f b/SRC/clar2v.f index a1e9bbd1..207728f4 100644 --- a/SRC/clar2v.f +++ b/SRC/clar2v.f @@ -1,6 +1,6 @@ SUBROUTINE CLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarcm.f b/SRC/clarcm.f index f01d683f..151a4771 100644 --- a/SRC/clarcm.f +++ b/SRC/clarcm.f @@ -1,6 +1,6 @@ SUBROUTINE CLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarf.f b/SRC/clarf.f index e98d8a8c..c17ac1d0 100644 --- a/SRC/clarf.f +++ b/SRC/clarf.f @@ -1,7 +1,7 @@ SUBROUTINE CLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarfb.f b/SRC/clarfb.f index 3418b460..be1bc3cf 100644 --- a/SRC/clarfb.f +++ b/SRC/clarfb.f @@ -2,7 +2,7 @@ $ T, LDT, C, LDC, WORK, LDWORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarfg.f b/SRC/clarfg.f index 8867f54b..695dd61f 100644 --- a/SRC/clarfg.f +++ b/SRC/clarfg.f @@ -1,6 +1,6 @@ SUBROUTINE CLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarfp.f b/SRC/clarfp.f index 51c2ba4f..de4a46c3 100644 --- a/SRC/clarfp.f +++ b/SRC/clarfp.f @@ -1,6 +1,6 @@ SUBROUTINE CLARFP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarft.f b/SRC/clarft.f index 725b84d5..8c257385 100644 --- a/SRC/clarft.f +++ b/SRC/clarft.f @@ -1,6 +1,6 @@ SUBROUTINE CLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -240,13 +240,13 @@ * CALL CTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF END IF T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF END IF 40 CONTINUE END IF diff --git a/SRC/clarfx.f b/SRC/clarfx.f index 2ab15b8e..686b1a19 100644 --- a/SRC/clarfx.f +++ b/SRC/clarfx.f @@ -1,7 +1,7 @@ SUBROUTINE CLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clargv.f b/SRC/clargv.f index 4579ff92..ac23a5ca 100644 --- a/SRC/clargv.f +++ b/SRC/clargv.f @@ -1,6 +1,6 @@ SUBROUTINE CLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarnv.f b/SRC/clarnv.f index 0795a07a..9c33c582 100644 --- a/SRC/clarnv.f +++ b/SRC/clarnv.f @@ -1,6 +1,6 @@ SUBROUTINE CLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarrv.f b/SRC/clarrv.f index 95cce4e5..8a3bb377 100644 --- a/SRC/clarrv.f +++ b/SRC/clarrv.f @@ -4,7 +4,7 @@ $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarscl2.f b/SRC/clarscl2.f new file mode 100644 index 00000000..22c54c09 --- /dev/null +++ b/SRC/clarscl2.f @@ -0,0 +1,54 @@ + SUBROUTINE CLARSCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + COMPLEX X( LDX, * ) + REAL D( * ) +* .. +* +* Purpose +* ======= +* +* CLARSCL2 performs a reciprocal diagonal scaling on an vector: +* x <-- inv(D) * x +* where the diagonal matrix D is stored as a vector. +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) REAL array, length N +* Diagonal matrix D, stored as a vector of length N. +* X (input/output) COMPLEX array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) / D(I) + END DO + END DO +* + RETURN + END +* diff --git a/SRC/clartg.f b/SRC/clartg.f index c521d330..2a21ddb0 100644 --- a/SRC/clartg.f +++ b/SRC/clartg.f @@ -1,6 +1,6 @@ SUBROUTINE CLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clartv.f b/SRC/clartv.f index 553a2ded..a6925a15 100644 --- a/SRC/clartv.f +++ b/SRC/clartv.f @@ -1,6 +1,6 @@ SUBROUTINE CLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarz.f b/SRC/clarz.f index 9bf7efbb..e6679292 100644 --- a/SRC/clarz.f +++ b/SRC/clarz.f @@ -1,6 +1,6 @@ SUBROUTINE CLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarzb.f b/SRC/clarzb.f index 77e24ba5..da6ac15b 100644 --- a/SRC/clarzb.f +++ b/SRC/clarzb.f @@ -1,7 +1,7 @@ SUBROUTINE CLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clarzt.f b/SRC/clarzt.f index 59260cae..000542c3 100644 --- a/SRC/clarzt.f +++ b/SRC/clarzt.f @@ -1,6 +1,6 @@ SUBROUTINE CLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clascl.f b/SRC/clascl.f index 4f18e904..8ebb8ad6 100644 --- a/SRC/clascl.f +++ b/SRC/clascl.f @@ -1,6 +1,6 @@ SUBROUTINE CLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clascl2.f b/SRC/clascl2.f new file mode 100644 index 00000000..9712f4d9 --- /dev/null +++ b/SRC/clascl2.f @@ -0,0 +1,54 @@ + SUBROUTINE CLASCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + REAL D( * ) + COMPLEX X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* CLASCL2 performs a diagonal scaling on a vector: +* x <-- D * x +* where the diagonal matrix D is stored as a vector. +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) REAL array, length N +* Diagonal matrix D, stored as a vector of length N. +* X (input/output) COMPLEX array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) * D(I) + END DO + END DO +* + RETURN + END +* diff --git a/SRC/claset.f b/SRC/claset.f index c47b7d7e..c12fe768 100644 --- a/SRC/claset.f +++ b/SRC/claset.f @@ -1,6 +1,6 @@ SUBROUTINE CLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clasr.f b/SRC/clasr.f index 74e412ce..5521bb13 100644 --- a/SRC/clasr.f +++ b/SRC/clasr.f @@ -1,6 +1,6 @@ SUBROUTINE CLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/classq.f b/SRC/classq.f index f4b4120d..ff1505f7 100644 --- a/SRC/classq.f +++ b/SRC/classq.f @@ -1,6 +1,6 @@ SUBROUTINE CLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/claswp.f b/SRC/claswp.f index 0ea8f165..71d7fa98 100644 --- a/SRC/claswp.f +++ b/SRC/claswp.f @@ -1,6 +1,6 @@ SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clasyf.f b/SRC/clasyf.f index 8d1ae0c9..1e5f88bb 100644 --- a/SRC/clasyf.f +++ b/SRC/clasyf.f @@ -1,6 +1,6 @@ SUBROUTINE CLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatbs.f b/SRC/clatbs.f index aa48c9c0..4d896ff0 100644 --- a/SRC/clatbs.f +++ b/SRC/clatbs.f @@ -1,7 +1,7 @@ SUBROUTINE CLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatdf.f b/SRC/clatdf.f index 39b12163..fc951cca 100644 --- a/SRC/clatdf.f +++ b/SRC/clatdf.f @@ -1,7 +1,7 @@ SUBROUTINE CLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatps.f b/SRC/clatps.f index 9f91ee3a..f395cb8e 100644 --- a/SRC/clatps.f +++ b/SRC/clatps.f @@ -1,7 +1,7 @@ SUBROUTINE CLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatrd.f b/SRC/clatrd.f index 8856ec24..04ef71fb 100644 --- a/SRC/clatrd.f +++ b/SRC/clatrd.f @@ -1,6 +1,6 @@ SUBROUTINE CLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatrs.f b/SRC/clatrs.f index 2a32eabe..e3106009 100644 --- a/SRC/clatrs.f +++ b/SRC/clatrs.f @@ -1,7 +1,7 @@ SUBROUTINE CLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatrz.f b/SRC/clatrz.f index 829fa63b..3c4ce27c 100644 --- a/SRC/clatrz.f +++ b/SRC/clatrz.f @@ -1,6 +1,6 @@ SUBROUTINE CLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clatzm.f b/SRC/clatzm.f index da8c1990..fe969ed2 100644 --- a/SRC/clatzm.f +++ b/SRC/clatzm.f @@ -1,6 +1,6 @@ SUBROUTINE CLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clauu2.f b/SRC/clauu2.f index 50c66a78..2670c6bd 100644 --- a/SRC/clauu2.f +++ b/SRC/clauu2.f @@ -1,6 +1,6 @@ SUBROUTINE CLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/clauum.f b/SRC/clauum.f index 9bc3a995..f65c6fb9 100644 --- a/SRC/clauum.f +++ b/SRC/clauum.f @@ -1,6 +1,6 @@ SUBROUTINE CLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbcon.f b/SRC/cpbcon.f index cbe86980..395e54e8 100644 --- a/SRC/cpbcon.f +++ b/SRC/cpbcon.f @@ -1,7 +1,7 @@ SUBROUTINE CPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbequ.f b/SRC/cpbequ.f index 07beb1b8..d6638559 100644 --- a/SRC/cpbequ.f +++ b/SRC/cpbequ.f @@ -1,6 +1,6 @@ SUBROUTINE CPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbrfs.f b/SRC/cpbrfs.f index b220be36..60082501 100644 --- a/SRC/cpbrfs.f +++ b/SRC/cpbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE CPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbstf.f b/SRC/cpbstf.f index 619f4693..2d6b3411 100644 --- a/SRC/cpbstf.f +++ b/SRC/cpbstf.f @@ -1,6 +1,6 @@ SUBROUTINE CPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbsv.f b/SRC/cpbsv.f index 4a7f62f8..7f1217d9 100644 --- a/SRC/cpbsv.f +++ b/SRC/cpbsv.f @@ -1,6 +1,6 @@ SUBROUTINE CPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbsvx.f b/SRC/cpbsvx.f index 90d25538..6b7fed9c 100644 --- a/SRC/cpbsvx.f +++ b/SRC/cpbsvx.f @@ -2,7 +2,7 @@ $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbtf2.f b/SRC/cpbtf2.f index 4049b90e..968d0895 100644 --- a/SRC/cpbtf2.f +++ b/SRC/cpbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE CPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbtrf.f b/SRC/cpbtrf.f index cee79d69..403225d2 100644 --- a/SRC/cpbtrf.f +++ b/SRC/cpbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE CPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpbtrs.f b/SRC/cpbtrs.f index ca66fd1e..50de5de5 100644 --- a/SRC/cpbtrs.f +++ b/SRC/cpbtrs.f @@ -1,6 +1,6 @@ SUBROUTINE CPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpftrf.f b/SRC/cpftrf.f new file mode 100644 index 00000000..cad4ff27 --- /dev/null +++ b/SRC/cpftrf.f @@ -0,0 +1,420 @@ + SUBROUTINE CPFTRF( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER N, INFO +* .. +* .. Array Arguments .. + COMPLEX A( 0: * ) +* +* Purpose +* ======= +* +* CPFTRF computes the Cholesky factorization of a complex Hermitian +* positive definite matrix A. +* +* The factorization has the form +* A = U**H * U, if UPLO = 'U', or +* A = L * L**H, if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular. +* +* This is the block version of the algorithm, calling Level 3 BLAS. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); +* On entry, the Hermitian matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is +* the Conjugate-transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization RFP A = U**H*U or RFP A = L*L**H. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i is not +* positive definite, and the factorization could not be +* completed. +* +* Further Notes on RFP Format: +* ============================ +* +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + COMPLEX CONE + PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CHERK, CPOTRF, CTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CPFTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL CPOTRF( 'L', N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE, A( 0 ), N, + + A( N1 ), N ) + CALL CHERK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE, + + A( N ), N ) + CALL CPOTRF( 'U', N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL CPOTRF( 'L', N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'L', 'L', 'N', 'N', N1, N2, CONE, A( N2 ), N, + + A( 0 ), N ) + CALL CHERK( 'U', 'C', N2, N1, -ONE, A( 0 ), N, ONE, + + A( N1 ), N ) + CALL CPOTRF( 'U', N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + CALL CPOTRF( 'U', N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE, A( 0 ), N1, + + A( N1*N1 ), N1 ) + CALL CHERK( 'L', 'C', N2, N1, -ONE, A( N1*N1 ), N1, ONE, + + A( 1 ), N1 ) + CALL CPOTRF( 'L', N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + CALL CPOTRF( 'U', N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'R', 'U', 'N', 'N', N2, N1, CONE, A( N2*N2 ), + + N2, A( 0 ), N2 ) + CALL CHERK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE, + + A( N1*N2 ), N2 ) + CALL CPOTRF( 'L', N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL CPOTRF( 'L', K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'R', 'L', 'C', 'N', K, K, CONE, A( 1 ), N+1, + + A( K+1 ), N+1 ) + CALL CHERK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE, + + A( 0 ), N+1 ) + CALL CPOTRF( 'U', K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL CPOTRF( 'L', K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'L', 'L', 'N', 'N', K, K, CONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL CHERK( 'U', 'C', K, K, -ONE, A( 0 ), N+1, ONE, + + A( K ), N+1 ) + CALL CPOTRF( 'U', K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL CPOTRF( 'U', K, A( 0+K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'L', 'U', 'C', 'N', K, K, CONE, A( K ), N1, + + A( K*( K+1 ) ), K ) + CALL CHERK( 'L', 'C', K, K, -ONE, A( K*( K+1 ) ), K, ONE, + + A( 0 ), K ) + CALL CPOTRF( 'L', K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL CPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRSM( 'R', 'U', 'N', 'N', K, K, CONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL CHERK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE, + + A( K*K ), K ) + CALL CPOTRF( 'L', K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CPFTRF +* + END diff --git a/SRC/cpftri.f b/SRC/cpftri.f new file mode 100644 index 00000000..82f97cf8 --- /dev/null +++ b/SRC/cpftri.f @@ -0,0 +1,384 @@ + SUBROUTINE CPFTRI( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. Array Arguments .. + COMPLEX A( 0: * ) +* .. +* +* Purpose +* ======= +* +* CPFTRI computes the inverse of a complex Hermitian positive definite +* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H +* computed by CPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); +* On entry, the Hermitian matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is +* the Conjugate-transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, the Hermitian inverse of the original matrix, in the +* same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the (i,i) element of the factor U or L is +* zero, and the inverse could not be computed. +* +* Note: +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + COMPLEX CONE + PARAMETER ( ONE = 1.0E+0, CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CTFTRI, CLAUUM, CTRMM, CHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CPFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL CTFTRI( TRANSR, UPLO, 'N', N, A, INFO ) + IF( INFO.GT.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or +* inv(L)^C*inv(L). There are eight cases. +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) +* T1 -> a(0), T2 -> a(n), S -> a(N1) +* + CALL CLAUUM( 'L', N1, A( 0 ), N, INFO ) + CALL CHERK( 'L', 'C', N1, N2, ONE, A( N1 ), N, ONE, + + A( 0 ), N ) + CALL CTRMM( 'L', 'U', 'N', 'N', N2, N1, CONE, A( N ), N, + + A( N1 ), N ) + CALL CLAUUM( 'U', N2, A( N ), N, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) +* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) +* T1 -> a(N2), T2 -> a(N1), S -> a(0) +* + CALL CLAUUM( 'L', N1, A( N2 ), N, INFO ) + CALL CHERK( 'L', 'N', N1, N2, ONE, A( 0 ), N, ONE, + + A( N2 ), N ) + CALL CTRMM( 'R', 'U', 'C', 'N', N1, N2, CONE, A( N1 ), N, + + A( 0 ), N ) + CALL CLAUUM( 'U', N2, A( N1 ), N, INFO ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) +* + CALL CLAUUM( 'U', N1, A( 0 ), N1, INFO ) + CALL CHERK( 'U', 'N', N1, N2, ONE, A( N1*N1 ), N1, ONE, + + A( 0 ), N1 ) + CALL CTRMM( 'R', 'L', 'N', 'N', N1, N2, CONE, A( 1 ), N1, + + A( N1*N1 ), N1 ) + CALL CLAUUM( 'L', N2, A( 1 ), N1, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is odd +* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) +* + CALL CLAUUM( 'U', N1, A( N2*N2 ), N2, INFO ) + CALL CHERK( 'U', 'C', N1, N2, ONE, A( 0 ), N2, ONE, + + A( N2*N2 ), N2 ) + CALL CTRMM( 'L', 'L', 'C', 'N', N2, N1, CONE, A( N1*N2 ), + + N2, A( 0 ), N2 ) + CALL CLAUUM( 'L', N2, A( N1*N2 ), N2, INFO ) +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL CLAUUM( 'L', K, A( 1 ), N+1, INFO ) + CALL CHERK( 'L', 'C', K, K, ONE, A( K+1 ), N+1, ONE, + + A( 1 ), N+1 ) + CALL CTRMM( 'L', 'U', 'N', 'N', K, K, CONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) + CALL CLAUUM( 'U', K, A( 0 ), N+1, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL CLAUUM( 'L', K, A( K+1 ), N+1, INFO ) + CALL CHERK( 'L', 'N', K, K, ONE, A( 0 ), N+1, ONE, + + A( K+1 ), N+1 ) + CALL CTRMM( 'R', 'U', 'C', 'N', K, K, CONE, A( K ), N+1, + + A( 0 ), N+1 ) + CALL CLAUUM( 'U', K, A( K ), N+1, INFO ) +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL CLAUUM( 'U', K, A( K ), K, INFO ) + CALL CHERK( 'U', 'N', K, K, ONE, A( K*( K+1 ) ), K, ONE, + + A( K ), K ) + CALL CTRMM( 'R', 'L', 'N', 'N', K, K, CONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + CALL CLAUUM( 'L', K, A( 0 ), K, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL CLAUUM( 'U', K, A( K*( K+1 ) ), K, INFO ) + CALL CHERK( 'U', 'C', K, K, ONE, A( 0 ), K, ONE, + + A( K*( K+1 ) ), K ) + CALL CTRMM( 'L', 'L', 'C', 'N', K, K, CONE, A( K*K ), K, + + A( 0 ), K ) + CALL CLAUUM( 'L', K, A( K*K ), K, INFO ) +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CPFTRI +* + END diff --git a/SRC/cpftrs.f b/SRC/cpftrs.f new file mode 100644 index 00000000..cfddeb6e --- /dev/null +++ b/SRC/cpftrs.f @@ -0,0 +1,230 @@ + SUBROUTINE CPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + COMPLEX A( 0: * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* CPFTRS solves a system of linear equations A*X = B with a Hermitian +* positive definite matrix A using the Cholesky factorization +* A = U**H*U or A = L*L**H computed by CPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) COMPLEX array, dimension ( N*(N+1)/2 ); +* The triangular factor U or L from the Cholesky factorization +* of RFP A = U**H*U or RFP A = L*L**H, as computed by CPFTRF. +* See note below for more details about RFP A. +* +* B (input/output) COMPLEX array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Note: +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CTFSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CPFTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + + RETURN +* +* start execution: there are two triangular solves +* + IF( LOWER ) THEN + CALL CTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, CONE, A, B, + + LDB ) + CALL CTFSM( TRANSR, 'L', UPLO, 'C', 'N', N, NRHS, CONE, A, B, + + LDB ) + ELSE + CALL CTFSM( TRANSR, 'L', UPLO, 'C', 'N', N, NRHS, CONE, A, B, + + LDB ) + CALL CTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, CONE, A, B, + + LDB ) + END IF +* + RETURN +* +* End of CPFTRS +* + END diff --git a/SRC/cpocon.f b/SRC/cpocon.f index d4b4c44b..4763b58a 100644 --- a/SRC/cpocon.f +++ b/SRC/cpocon.f @@ -1,7 +1,7 @@ SUBROUTINE CPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpoequ.f b/SRC/cpoequ.f index f08acd3e..acd0057e 100644 --- a/SRC/cpoequ.f +++ b/SRC/cpoequ.f @@ -1,6 +1,6 @@ SUBROUTINE CPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpoequb.f b/SRC/cpoequb.f new file mode 100644 index 00000000..88a87b71 --- /dev/null +++ b/SRC/cpoequb.f @@ -0,0 +1,160 @@ + SUBROUTINE CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + REAL AMAX, SCOND +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) + REAL S( * ) +* .. +* +* Purpose +* ======= +* +* CPOEQUB computes row and column scalings intended to equilibrate a +* symmetric positive definite matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The N-by-N symmetric positive definite matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) REAL array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) REAL +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I + REAL SMIN, BASE, TMP + COMPLEX ZDUM +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, LOG, INT, REAL, AIMAG +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* +* Positive definite only performs 1 pass of equilibration. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CPOEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF + + BASE = SLAMCH( 'B' ) + TMP = -0.5 / LOG ( BASE ) +* +* Find the minimum and maximum diagonal elements. +* + S( 1 ) = A( 1, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) + DO 10 I = 2, N + S( I ) = A( I, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = BASE ** INT( TMP * LOG( S( I ) ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)). +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF +* + RETURN +* +* End of CPOEQUB +* + END diff --git a/SRC/cporfs.f b/SRC/cporfs.f index 49001285..aece7b6a 100644 --- a/SRC/cporfs.f +++ b/SRC/cporfs.f @@ -1,7 +1,7 @@ SUBROUTINE CPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cporfsx.f b/SRC/cporfsx.f new file mode 100644 index 00000000..ab4ef3fa --- /dev/null +++ b/SRC/cporfsx.f @@ -0,0 +1,568 @@ + Subroutine CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, + $ LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL RWORK( * ), S( * ), PARAMS(*), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* CPORFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric positive +* definite, and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular part +* of the matrix A, and the strictly lower triangular part of A +* is not referenced. If UPLO = 'L', the leading N-by-N lower +* triangular part of A contains the lower triangular part of +* the matrix A, and the strictly upper triangular part of A is +* not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX array, dimension (LDAF,N) +* The triangular factor U or L from the Cholesky factorization +* A = U**T*U or A = L*L**T, as computed by SPOTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* S (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) COMPLEX array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CPOCON, CLA_PORFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, CLANHE, CLA_PORCOND_X, CLA_PORCOND_C + REAL SLAMCH, CLANHE, CLA_PORCOND_X, CLA_PORCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS(LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS(LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CPORFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = CLANHE( NORM, UPLO, N, A, LDA, WORK ) + CALL CPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, + $ INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + CALL CLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK(N+1), WORK(1), WORK(2*N+1), WORK(1), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, + $ S, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = CLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, + $ S, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = CLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, + $ X(1,J), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF (RCOND_TMP .LT. ILLRCOND_THRESH) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of CPORFSX +* + END diff --git a/SRC/cposv.f b/SRC/cposv.f index 8e57d3f0..1694a534 100644 --- a/SRC/cposv.f +++ b/SRC/cposv.f @@ -1,6 +1,6 @@ SUBROUTINE CPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cposvx.f b/SRC/cposvx.f index af37ec8d..e286b1de 100644 --- a/SRC/cposvx.f +++ b/SRC/cposvx.f @@ -2,7 +2,7 @@ $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cposvxx.f b/SRC/cposvxx.f new file mode 100644 index 00000000..1ad3690e --- /dev/null +++ b/SRC/cposvxx.f @@ -0,0 +1,552 @@ + SUBROUTINE CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, + $ S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ WORK( * ), X( LDX, * ) + REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* CPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T +* to compute the solution to a complex system of linear equations +* A * X = B, where A is an N-by-N symmetric positive definite matrix +* and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. CPOSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* CPOSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* CPOSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what CPOSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +* factor the matrix A (after equilibration if FACT = 'E') as +* A = U**T* U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is a lower triangular +* matrix. +* +* 3. If the leading i-by-i principal minor is not positive definite, +* then the routine returns with INFO = i. Otherwise, the factored +* form of A is used to estimate the condition number of the matrix +* A (see argument RCOND). If the reciprocal of the condition number +* is less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(S) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF contains the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A and AF are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX array, dimension (LDA,N) +* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = +* 'Y', then A must contain the equilibrated matrix +* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper +* triangular part of A contains the upper triangular part of the +* matrix A, and the strictly lower triangular part of A is not +* referenced. If UPLO = 'L', the leading N-by-N lower triangular +* part of A contains the lower triangular part of the matrix A, and +* the strictly upper triangular part of A is not referenced. A is +* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = +* 'N' on exit. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T, in the same storage +* format as A. If EQUED .ne. 'N', then AF is the factored +* form of the equilibrated matrix diag(S)*A*diag(S). +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the original +* matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the equilibrated +* matrix A (see the description of A for the form of the +* equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) COMPLEX array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, CLA_PORPVGRW + LOGICAL LSAME + REAL SLAMCH, CLA_PORPVGRW +* .. +* .. External Subroutines .. + EXTERNAL CPOCON, CPOEQUB, CPOTRF, CPOTRS, CLACPY, + $ CLAQHE, XERBLA, CLASCL2, CPORFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in CPORFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until CPORFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CPOSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL CPOEQUB( N, A, LDA, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL CLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL CLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL CPOTRF( UPLO, N, AF, LDAF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = CLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = CLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) +* +* Compute the solution matrix X. +* + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL CPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL CPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO ) + +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL CLASCL2( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of CPOSVXX +* + END diff --git a/SRC/cpotf2.f b/SRC/cpotf2.f index 8edd89a3..63643327 100644 --- a/SRC/cpotf2.f +++ b/SRC/cpotf2.f @@ -1,6 +1,6 @@ SUBROUTINE CPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -73,9 +73,9 @@ REAL AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, SISNAN COMPLEX CDOTC - EXTERNAL LSAME, CDOTC + EXTERNAL LSAME, CDOTC, SISNAN * .. * .. External Subroutines .. EXTERNAL CGEMV, CLACGV, CSSCAL, XERBLA @@ -116,7 +116,7 @@ * AJJ = REAL( A( J, J ) ) - CDOTC( J-1, A( 1, J ), 1, $ A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF @@ -143,7 +143,7 @@ * AJJ = REAL( A( J, J ) ) - CDOTC( J-1, A( J, 1 ), LDA, $ A( J, 1 ), LDA ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF diff --git a/SRC/cpotrf.f b/SRC/cpotrf.f index f6965275..755bc2db 100644 --- a/SRC/cpotrf.f +++ b/SRC/cpotrf.f @@ -1,6 +1,6 @@ SUBROUTINE CPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpotri.f b/SRC/cpotri.f index de48482f..14dde3ff 100644 --- a/SRC/cpotri.f +++ b/SRC/cpotri.f @@ -1,6 +1,6 @@ SUBROUTINE CPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpotrs.f b/SRC/cpotrs.f index 3bfe1264..d2a13a8e 100644 --- a/SRC/cpotrs.f +++ b/SRC/cpotrs.f @@ -1,6 +1,6 @@ SUBROUTINE CPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cppcon.f b/SRC/cppcon.f index b7891424..ac811de1 100644 --- a/SRC/cppcon.f +++ b/SRC/cppcon.f @@ -1,6 +1,6 @@ SUBROUTINE CPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cppequ.f b/SRC/cppequ.f index 369e1232..ec5464ea 100644 --- a/SRC/cppequ.f +++ b/SRC/cppequ.f @@ -1,6 +1,6 @@ SUBROUTINE CPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpprfs.f b/SRC/cpprfs.f index b9e84355..98cbc4e7 100644 --- a/SRC/cpprfs.f +++ b/SRC/cpprfs.f @@ -1,7 +1,7 @@ SUBROUTINE CPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cppsv.f b/SRC/cppsv.f index 078d4c97..3f73bb64 100644 --- a/SRC/cppsv.f +++ b/SRC/cppsv.f @@ -1,6 +1,6 @@ SUBROUTINE CPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cppsvx.f b/SRC/cppsvx.f index 1dec90c6..51c48c32 100644 --- a/SRC/cppsvx.f +++ b/SRC/cppsvx.f @@ -1,7 +1,7 @@ SUBROUTINE CPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpptrf.f b/SRC/cpptrf.f index 48148e3e..8d6a511e 100644 --- a/SRC/cpptrf.f +++ b/SRC/cpptrf.f @@ -1,6 +1,6 @@ SUBROUTINE CPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpptri.f b/SRC/cpptri.f index 257c3908..7d63eaad 100644 --- a/SRC/cpptri.f +++ b/SRC/cpptri.f @@ -1,6 +1,6 @@ SUBROUTINE CPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpptrs.f b/SRC/cpptrs.f index aa64389b..50e0c0f0 100644 --- a/SRC/cpptrs.f +++ b/SRC/cpptrs.f @@ -1,6 +1,6 @@ SUBROUTINE CPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpstf2.f b/SRC/cpstf2.f new file mode 100644 index 00000000..2e319133 --- /dev/null +++ b/SRC/cpstf2.f @@ -0,0 +1,327 @@ + SUBROUTINE CPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK PROTOTYPE routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) + REAL WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* CPSTF2 computes the Cholesky factorization with complete +* pivoting of a complex Hermitian positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 2 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) REAL +* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK REAL array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX CTEMP + REAL AJJ, SSTOP, STEMP + INTEGER I, ITEMP, J, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME, SISNAN + EXTERNAL SLAMCH, LSAME, SISNAN +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CLACGV, CSSCAL, CSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, REAL, SQRT +* .. +* .. 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( 'CPSTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + DO 110 I = 1, N + WORK( I ) = REAL( A( I, I ) ) + 110 CONTINUE + PVT = MAXLOC( WORK( 1:N ), 1 ) + AJJ = REAL ( A( PVT, PVT ) ) + IF( AJJ.EQ.ZERO.OR.SISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 200 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + SSTOP = N * SLAMCH( 'Epsilon' ) * AJJ + ELSE + SSTOP = TOL + END IF +* +* Set first half of WORK to zero, holds dot products +* + DO 120 I = 1, N + WORK( I ) = 0 + 120 CONTINUE +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 150 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 130 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + + $ REAL( CONJG( A( J-1, I ) )* + $ A( J-1, I ) ) + END IF + WORK( N+I ) = REAL( A( I, I ) ) - WORK( I ) +* + 130 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL CSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL CSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + DO 140 I = J + 1, PVT - 1 + CTEMP = CONJG( A( J, I ) ) + A( J, I ) = CONJG( A( I, PVT ) ) + A( I, PVT ) = CTEMP + 140 CONTINUE + A( J, PVT ) = CONJG( A( J, PVT ) ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J +* + IF( J.LT.N ) THEN + CALL CLACGV( J-1, A( 1, J ), 1 ) + CALL CGEMV( 'Trans', J-1, N-J, -CONE, A( 1, J+1 ), LDA, + $ A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) + CALL CLACGV( J-1, A( 1, J ), 1 ) + CALL CSSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 150 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 180 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 160 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + + $ REAL( CONJG( A( I, J-1 ) )* + $ A( I, J-1 ) ) + END IF + WORK( N+I ) = REAL( A( I, I ) ) - WORK( I ) +* + 160 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL CSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL CSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1, PVT ), + $ 1 ) + DO 170 I = J + 1, PVT - 1 + CTEMP = CONJG( A( I, J ) ) + A( I, J ) = CONJG( A( PVT, I ) ) + A( PVT, I ) = CTEMP + 170 CONTINUE + A( PVT, J ) = CONJG( A( PVT, J ) ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J +* + IF( J.LT.N ) THEN + CALL CLACGV( J-1, A( J, 1 ), LDA ) + CALL CGEMV( 'No Trans', N-J, J-1, -CONE, A( J+1, 1 ), + $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) + CALL CLACGV( J-1, A( J, 1 ), LDA ) + CALL CSSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 180 CONTINUE +* + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 200 + 190 CONTINUE +* +* Rank is number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 200 CONTINUE + RETURN +* +* End of CPSTF2 +* + END diff --git a/SRC/cpstrf.f b/SRC/cpstrf.f new file mode 100644 index 00000000..ff99c5ef --- /dev/null +++ b/SRC/cpstrf.f @@ -0,0 +1,384 @@ + SUBROUTINE CPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ) + REAL WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* CPSTRF computes the Cholesky factorization with complete +* pivoting of a complex Hermitian positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 3 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) REAL +* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK REAL array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX CTEMP + REAL AJJ, SSTOP, STEMP + INTEGER I, ITEMP, J, JB, K, NB, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + REAL SLAMCH + INTEGER ILAENV + LOGICAL LSAME, SISNAN + EXTERNAL SLAMCH, ILAENV, LSAME, SISNAN +* .. +* .. External Subroutines .. + EXTERNAL CGEMV, CHERK, CLACGV, CPSTF2, CSSCAL, CSWAP, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, MIN, REAL, SQRT, MAXLOC +* .. +* .. 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( 'CPSTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get block size +* + NB = ILAENV( 1, 'CPOTRF', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL CPSTF2( UPLO, N, A( 1, 1 ), LDA, PIV, RANK, TOL, WORK, + $ INFO ) + GO TO 230 +* + ELSE +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + DO 110 I = 1, N + WORK( I ) = REAL( A( I, I ) ) + 110 CONTINUE + PVT = MAXLOC( WORK( 1:N ), 1 ) + AJJ = REAL( A( PVT, PVT ) ) + IF( AJJ.EQ.ZERO.OR.SISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 230 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + SSTOP = N * SLAMCH( 'Epsilon' ) * AJJ + ELSE + SSTOP = TOL + END IF +* +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 160 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 120 I = K, N + WORK( I ) = 0 + 120 CONTINUE +* + DO 150 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 130 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + + $ REAL( CONJG( A( J-1, I ) )* + $ A( J-1, I ) ) + END IF + WORK( N+I ) = REAL( A( I, I ) ) - WORK( I ) +* + 130 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 220 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL CSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL CSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + DO 140 I = J + 1, PVT - 1 + CTEMP = CONJG( A( J, I ) ) + A( J, I ) = CONJG( A( I, PVT ) ) + A( I, PVT ) = CTEMP + 140 CONTINUE + A( J, PVT ) = CONJG( A( J, PVT ) ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL CLACGV( J-1, A( 1, J ), 1 ) + CALL CGEMV( 'Trans', J-K, N-J, -CONE, A( K, J+1 ), + $ LDA, A( K, J ), 1, CONE, A( J, J+1 ), + $ LDA ) + CALL CLACGV( J-1, A( 1, J ), 1 ) + CALL CSSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 150 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL CHERK( 'Upper', 'Conj Trans', N-J+1, JB, -ONE, + $ A( K, J ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 160 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 210 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 170 I = K, N + WORK( I ) = 0 + 170 CONTINUE +* + DO 200 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 180 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + + $ REAL( CONJG( A( I, J-1 ) )* + $ A( I, J-1 ) ) + END IF + WORK( N+I ) = REAL( A( I, I ) ) - WORK( I ) +* + 180 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 220 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL CSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL CSWAP( N-PVT, A( PVT+1, J ), 1, + $ A( PVT+1, PVT ), 1 ) + DO 190 I = J + 1, PVT - 1 + CTEMP = CONJG( A( I, J ) ) + A( I, J ) = CONJG( A( PVT, I ) ) + A( PVT, I ) = CTEMP + 190 CONTINUE + A( PVT, J ) = CONJG( A( PVT, J ) ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL CLACGV( J-1, A( J, 1 ), LDA ) + CALL CGEMV( 'No Trans', N-J, J-K, -CONE, + $ A( J+1, K ), LDA, A( J, K ), LDA, CONE, + $ A( J+1, J ), 1 ) + CALL CLACGV( J-1, A( J, 1 ), LDA ) + CALL CSSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 200 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL CHERK( 'Lower', 'No Trans', N-J+1, JB, -ONE, + $ A( J, K ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 210 CONTINUE +* + END IF + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 230 + 220 CONTINUE +* +* Rank is the number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 230 CONTINUE + RETURN +* +* End of CPSTRF +* + END diff --git a/SRC/cptcon.f b/SRC/cptcon.f index 81979f86..54402211 100644 --- a/SRC/cptcon.f +++ b/SRC/cptcon.f @@ -1,6 +1,6 @@ SUBROUTINE CPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpteqr.f b/SRC/cpteqr.f index 3483a294..31b6b04d 100644 --- a/SRC/cpteqr.f +++ b/SRC/cpteqr.f @@ -1,6 +1,6 @@ SUBROUTINE CPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cptrfs.f b/SRC/cptrfs.f index bc487a8b..a95cce4a 100644 --- a/SRC/cptrfs.f +++ b/SRC/cptrfs.f @@ -1,7 +1,7 @@ SUBROUTINE CPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cptsv.f b/SRC/cptsv.f index dd2dbd52..945a281c 100644 --- a/SRC/cptsv.f +++ b/SRC/cptsv.f @@ -1,6 +1,6 @@ SUBROUTINE CPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cptsvx.f b/SRC/cptsvx.f index 3abfa46c..0f73da01 100644 --- a/SRC/cptsvx.f +++ b/SRC/cptsvx.f @@ -1,7 +1,7 @@ SUBROUTINE CPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpttrf.f b/SRC/cpttrf.f index e02daf95..70bf326f 100644 --- a/SRC/cpttrf.f +++ b/SRC/cpttrf.f @@ -1,6 +1,6 @@ SUBROUTINE CPTTRF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cpttrs.f b/SRC/cpttrs.f index b875ffae..11815e80 100644 --- a/SRC/cpttrs.f +++ b/SRC/cpttrs.f @@ -1,6 +1,6 @@ SUBROUTINE CPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cptts2.f b/SRC/cptts2.f index 95d835e0..b4aa625a 100644 --- a/SRC/cptts2.f +++ b/SRC/cptts2.f @@ -1,6 +1,6 @@ SUBROUTINE CPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -1,6 +1,6 @@ SUBROUTINE CROT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cspcon.f b/SRC/cspcon.f index bfab77ba..1740f89e 100644 --- a/SRC/cspcon.f +++ b/SRC/cspcon.f @@ -1,6 +1,6 @@ SUBROUTINE CSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cspmv.f b/SRC/cspmv.f index aff8085d..b1fca225 100644 --- a/SRC/cspmv.f +++ b/SRC/cspmv.f @@ -1,6 +1,6 @@ SUBROUTINE CSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -1,6 +1,6 @@ SUBROUTINE CSPR( UPLO, N, ALPHA, X, INCX, AP ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csprfs.f b/SRC/csprfs.f index 430cec52..4652e7c0 100644 --- a/SRC/csprfs.f +++ b/SRC/csprfs.f @@ -1,7 +1,7 @@ SUBROUTINE CSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cspsv.f b/SRC/cspsv.f index b07ed386..5e9d8539 100644 --- a/SRC/cspsv.f +++ b/SRC/cspsv.f @@ -1,6 +1,6 @@ SUBROUTINE CSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cspsvx.f b/SRC/cspsvx.f index fbf6cede..9ac2c4a5 100644 --- a/SRC/cspsvx.f +++ b/SRC/cspsvx.f @@ -1,7 +1,7 @@ SUBROUTINE CSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csptrf.f b/SRC/csptrf.f index 7944fe1d..c2df86d3 100644 --- a/SRC/csptrf.f +++ b/SRC/csptrf.f @@ -1,6 +1,6 @@ SUBROUTINE CSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csptri.f b/SRC/csptri.f index d63a9ad1..70c18349 100644 --- a/SRC/csptri.f +++ b/SRC/csptri.f @@ -1,6 +1,6 @@ SUBROUTINE CSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csptrs.f b/SRC/csptrs.f index 7746149d..5df9627a 100644 --- a/SRC/csptrs.f +++ b/SRC/csptrs.f @@ -1,6 +1,6 @@ SUBROUTINE CSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csrscl.f b/SRC/csrscl.f index 3e7345c0..15032fe6 100644 --- a/SRC/csrscl.f +++ b/SRC/csrscl.f @@ -1,6 +1,6 @@ SUBROUTINE CSRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cstedc.f b/SRC/cstedc.f index a2ed1cb0..b93d92cf 100644 --- a/SRC/cstedc.f +++ b/SRC/cstedc.f @@ -1,7 +1,7 @@ SUBROUTINE CSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cstegr.f b/SRC/cstegr.f index ff3ff3f6..184430ce 100644 --- a/SRC/cstegr.f +++ b/SRC/cstegr.f @@ -5,7 +5,7 @@ IMPLICIT NONE * * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cstein.f b/SRC/cstein.f index 6bd02117..3289938b 100644 --- a/SRC/cstein.f +++ b/SRC/cstein.f @@ -1,7 +1,7 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cstemr.f b/SRC/cstemr.f index ddb2e0c9..641591f7 100644 --- a/SRC/cstemr.f +++ b/SRC/cstemr.f @@ -3,7 +3,7 @@ $ IWORK, LIWORK, INFO ) IMPLICIT NONE * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csteqr.f b/SRC/csteqr.f index 6e130ea2..9d2b4af0 100644 --- a/SRC/csteqr.f +++ b/SRC/csteqr.f @@ -1,6 +1,6 @@ SUBROUTINE CSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csycon.f b/SRC/csycon.f index 0453c894..93b569d1 100644 --- a/SRC/csycon.f +++ b/SRC/csycon.f @@ -1,7 +1,7 @@ SUBROUTINE CSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csyequb.f b/SRC/csyequb.f new file mode 100644 index 00000000..90d57d90 --- /dev/null +++ b/SRC/csyequb.f @@ -0,0 +1,256 @@ + SUBROUTINE CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + REAL AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), WORK( * ) + REAL S( * ) +* .. +* +* Purpose +* ======= +* +* CSYEQUB computes row and column scalings intended to equilibrate a +* symmetric matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The N-by-N symmetric matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) REAL array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) REAL +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + REAL AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP + COMPLEX ZDUM +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL CLASSQ +* .. +* .. Statement Functions .. + REAL CABS1 +* .. +* Statement Function Definitions + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. 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( 'CSYEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) + END DO + S( J ) = MAX( S( J ), CABS1( A( J, J) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1 (A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0 / S( J ) + END DO + + TOL = ONE / SQRT( 2.0E0 * N ) + + DO ITER = 1, MAX_ITER + SCALE = 0.0 + SUMSQ = 0.0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0 + DO I = 2*N+1, 3*N + WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG + END DO + CALL CLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 + + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO + END DO + + 999 CONTINUE + + SMLNUM = SLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT( AVG ) + BASE = SLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) +* + END diff --git a/SRC/csymv.f b/SRC/csymv.f index e08240fe..e1da20a9 100644 --- a/SRC/csymv.f +++ b/SRC/csymv.f @@ -1,6 +1,6 @@ SUBROUTINE CSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -1,6 +1,6 @@ SUBROUTINE CSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csyrfs.f b/SRC/csyrfs.f index c0970d1e..cb2304aa 100644 --- a/SRC/csyrfs.f +++ b/SRC/csyrfs.f @@ -1,7 +1,7 @@ SUBROUTINE CSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csyrfsx.f b/SRC/csyrfsx.f new file mode 100644 index 00000000..42aa33bf --- /dev/null +++ b/SRC/csyrfsx.f @@ -0,0 +1,575 @@ + Subroutine CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* CSYRFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric indefinite, and +* provides error bounds and backward error estimates for the +* solution. In addition to normwise error bound, the code provides +* maximum componentwise error bound if possible. See comments for +* ERR_BNDS_N and ERR_BNDS_C for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX array, dimension (LDAF,N) +* The factored form of the matrix A. AF contains the block +* diagonal matrix D and the multipliers used to obtain the +* factor U or L from the factorization A = U*D*U**T or A = +* L*D*L**T as computed by SSYTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by SSYTRF. +* +* S (input or output) REAL array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) COMPLEX array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CSYCON, CLA_SYRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, CLANSY, CLA_SYRCOND_X, CLA_SYRCOND_C + REAL SLAMCH, CLANSY, CLA_SYRCOND_X, CLA_SYRCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = CLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL CSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + CALL CLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK(N+1), RWORK, WORK(2*N+1), WORK(1), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = CLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = CLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, + $ IPIV, X(1,J), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of CSYRFSX +* + END diff --git a/SRC/csysv.f b/SRC/csysv.f index 132256b9..340d5a85 100644 --- a/SRC/csysv.f +++ b/SRC/csysv.f @@ -1,7 +1,7 @@ SUBROUTINE CSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csysvx.f b/SRC/csysvx.f index a1dc1505..91083f1e 100644 --- a/SRC/csysvx.f +++ b/SRC/csysvx.f @@ -2,7 +2,7 @@ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csysvxx.f b/SRC/csysvxx.f new file mode 100644 index 00000000..3f4fe8ae --- /dev/null +++ b/SRC/csysvxx.f @@ -0,0 +1,562 @@ + SUBROUTINE CSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* CSYSVXX uses the diagonal pivoting factorization to compute the +* solution to a complex system of linear equations A * X = B, where +* A is an N-by-N symmetric matrix and X and B are N-by-NRHS +* matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. CSYSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* CSYSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* CSYSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what CSYSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = U * D * U**T, if UPLO = 'U', or +* A = L * D * L**T, if UPLO = 'L', +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* 3. If some D(i,i)=0, so that D is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is +* less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(R) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T as computed by SSYTRF. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains details of the interchanges and the block +* structure of D, as determined by SSYTRF. If IPIV(k) > 0, +* then rows and columns k and IPIV(k) were interchanged and +* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +* then rows and columns k+1 and -IPIV(k) were interchanged +* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains details of the interchanges and the block +* structure of D, as determined by SSYTRF. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) REAL array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) COMPLEX array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) COMPLEX array, dimension (2*N) +* +* RWORK (workspace) REAL array, dimension (3*N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, CLA_SYRPVGRW + LOGICAL LSAME + REAL SLAMCH, CLA_SYRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL CSYCON, CSYEQUB, CSYTRF, CSYTRS, CLACPY, + $ CLAQSY, XERBLA, CLASCL2, CSYRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in CSYRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until CSYRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME(UPLO, 'U') .AND. + $ .NOT.LSAME(UPLO, 'L') ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CSYSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL CSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL CLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + + END IF +* +* Scale the right hand-side. +* + IF( RCEQU ) CALL CLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL CLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL CSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF ( N.GT.0 ) + $ RPVGRW = CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF ( N.GT.0 ) + $ RPVGRW = CLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) +* +* Compute the solution matrix X. +* + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL CSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL CSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL CLASCL2 (N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of CSYSVXX +* + END diff --git a/SRC/csytf2.f b/SRC/csytf2.f index 50f24ee6..7f1290f0 100644 --- a/SRC/csytf2.f +++ b/SRC/csytf2.f @@ -1,6 +1,6 @@ SUBROUTINE CSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csytrf.f b/SRC/csytrf.f index 68cb52c9..a3ac09c4 100644 --- a/SRC/csytrf.f +++ b/SRC/csytrf.f @@ -1,6 +1,6 @@ SUBROUTINE CSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csytri.f b/SRC/csytri.f index 7b246387..86db4a98 100644 --- a/SRC/csytri.f +++ b/SRC/csytri.f @@ -1,6 +1,6 @@ SUBROUTINE CSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/csytrs.f b/SRC/csytrs.f index ba084142..75dbf31b 100644 --- a/SRC/csytrs.f +++ b/SRC/csytrs.f @@ -1,6 +1,6 @@ SUBROUTINE CSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctbcon.f b/SRC/ctbcon.f index 52efe890..8cbe31b6 100644 --- a/SRC/ctbcon.f +++ b/SRC/ctbcon.f @@ -1,7 +1,7 @@ SUBROUTINE CTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctbrfs.f b/SRC/ctbrfs.f index e861416b..6d2004db 100644 --- a/SRC/ctbrfs.f +++ b/SRC/ctbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE CTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctbtrs.f b/SRC/ctbtrs.f index da333e47..e7deef57 100644 --- a/SRC/ctbtrs.f +++ b/SRC/ctbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE CTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctfsm.f b/SRC/ctfsm.f new file mode 100644 index 00000000..e26a769a --- /dev/null +++ b/SRC/ctfsm.f @@ -0,0 +1,922 @@ + SUBROUTINE CTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, + + B, LDB ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO + INTEGER LDB, M, N + COMPLEX ALPHA +* .. +* .. Array Arguments .. + COMPLEX A( 0: * ), B( 0: LDB-1, 0: * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for A in RFP Format. +* +* CTFSM solves the matrix equation +* +* op( A )*X = alpha*B or X*op( A ) = alpha*B +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = conjg( A' ). +* +* A is in Rectangular Full Packed (RFP) Format. +* +* The matrix X is overwritten on B. +* +* Arguments +* ========== +* +* TRANSR - (input) CHARACTER +* = 'N': The Normal Form of RFP A is stored; +* = 'C': The Conjugate-transpose Form of RFP A is stored. +* +* SIDE - (input) CHARACTER +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* Unchanged on exit. +* +* UPLO - (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix +* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER +* On entry, TRANS specifies the form of op( A ) to be used +* in the matrix multiplication as follows: +* +* TRANS = 'N' or 'n' op( A ) = A. +* +* TRANS = 'C' or 'c' op( A ) = conjg( A' ). +* +* Unchanged on exit. +* +* DIAG - (input) CHARACTER +* On entry, DIAG specifies whether or not RFP A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - (input) INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - (input) COMPLEX. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - (input) COMPLEX array, dimension ( N*(N+1)/2 ); +* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. +* RFP Format is described by TRANSR, UPLO and N as follows: +* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as +* defined when TRANSR = 'N'. The contents of RFP A are defined +* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT +* elements of upper packed A either in normal or +* conjugate-transpose Format. If UPLO = 'L' the RFP A contains +* the NT elements of lower packed A either in normal or +* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is +* even and is N when is odd. +* See the Note below for more details. Unchanged on exit. +* +* B - (input/ouptut) COMPLEX array, DIMENSION ( LDB, N ) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB - (input) INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* .. +* .. Parameters .. + COMPLEX CONE, CZERO + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ), + + CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, + + NOTRANS + INTEGER M1, M2, N1, N2, K, INFO, I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CGEMM, CTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LSIDE = LSAME( SIDE, 'L' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTFSM ', -INFO ) + RETURN + END IF +* +* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + + RETURN +* +* Quick return when ALPHA.EQ.(0E+0,0E+0) +* + IF( ALPHA.EQ.CZERO ) THEN + DO 20 J = 0, N - 1 + DO 10 I = 0, M - 1 + B( I, J ) = CZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* + IF( LSIDE ) THEN +* +* SIDE = 'L' +* +* A is M-by-M. +* If M is odd, set NISODD = .TRUE., and M1 and M2. +* If M is even, NISODD = .FALSE., and M. +* + IF( MOD( M, 2 ).EQ.0 ) THEN + MISODD = .FALSE. + K = M / 2 + ELSE + MISODD = .TRUE. + IF( LOWER ) THEN + M2 = M / 2 + M1 = M - M2 + ELSE + M1 = M / 2 + M2 = M - M1 + END IF + END IF +* + IF( MISODD ) THEN +* +* SIDE = 'L' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL CTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( 0 ), M, B, LDB ) + CALL CGEMM( 'N', 'N', M2, N, M1, -CONE, A( M1 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL CTRSM( 'L', 'U', 'C', DIAG, M2, N, CONE, + + A( M ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'C' +* + CALL CTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M ), M, B( M1, 0 ), LDB ) + CALL CGEMM( 'C', 'N', M1, N, M2, -CONE, A( M1 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'L', 'C', DIAG, M1, N, CONE, + + A( 0 ), M, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL CTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( M2 ), M, B, LDB ) + CALL CGEMM( 'C', 'N', M2, N, M1, -CONE, A( 0 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL CTRSM( 'L', 'U', 'C', DIAG, M2, N, CONE, + + A( M1 ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'C' +* + CALL CTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M1 ), M, B( M1, 0 ), LDB ) + CALL CGEMM( 'N', 'N', M1, N, M2, -CONE, A( 0 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'L', 'C', DIAG, M1, N, CONE, + + A( M2 ), M, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is odd, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'N' +* + CALL CTRSM( 'L', 'U', 'C', DIAG, M1, N, ALPHA, + + A( 0 ), M1, B, LDB ) + CALL CGEMM( 'C', 'N', M2, N, M1, -CONE, A( M1*M1 ), + + M1, B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL CTRSM( 'L', 'L', 'N', DIAG, M2, N, CONE, + + A( 1 ), M1, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'C' +* + CALL CTRSM( 'L', 'L', 'C', DIAG, M2, N, ALPHA, + + A( 1 ), M1, B( M1, 0 ), LDB ) + CALL CGEMM( 'N', 'N', M1, N, M2, -CONE, A( M1*M1 ), + + M1, B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'U', 'N', DIAG, M1, N, CONE, + + A( 0 ), M1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'N' +* + CALL CTRSM( 'L', 'U', 'C', DIAG, M1, N, ALPHA, + + A( M2*M2 ), M2, B, LDB ) + CALL CGEMM( 'N', 'N', M2, N, M1, -CONE, A( 0 ), M2, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL CTRSM( 'L', 'L', 'N', DIAG, M2, N, CONE, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'C' +* + CALL CTRSM( 'L', 'L', 'C', DIAG, M2, N, ALPHA, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) + CALL CGEMM( 'C', 'N', M1, N, M2, -CONE, A( 0 ), M2, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'U', 'N', DIAG, M1, N, CONE, + + A( M2*M2 ), M2, B, LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL CTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( 1 ), M+1, B, LDB ) + CALL CGEMM( 'N', 'N', K, N, K, -CONE, A( K+1 ), + + M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL CTRSM( 'L', 'U', 'C', DIAG, K, N, CONE, + + A( 0 ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'C' +* + CALL CTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( 0 ), M+1, B( K, 0 ), LDB ) + CALL CGEMM( 'C', 'N', K, N, K, -CONE, A( K+1 ), + + M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'L', 'C', DIAG, K, N, CONE, + + A( 1 ), M+1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL CTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( K+1 ), M+1, B, LDB ) + CALL CGEMM( 'C', 'N', K, N, K, -CONE, A( 0 ), M+1, + + B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL CTRSM( 'L', 'U', 'C', DIAG, K, N, CONE, + + A( K ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'C' + CALL CTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( K ), M+1, B( K, 0 ), LDB ) + CALL CGEMM( 'N', 'N', K, N, K, -CONE, A( 0 ), M+1, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'L', 'C', DIAG, K, N, CONE, + + A( K+1 ), M+1, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is even, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'N' +* + CALL CTRSM( 'L', 'U', 'C', DIAG, K, N, ALPHA, + + A( K ), K, B, LDB ) + CALL CGEMM( 'C', 'N', K, N, K, -CONE, + + A( K*( K+1 ) ), K, B, LDB, ALPHA, + + B( K, 0 ), LDB ) + CALL CTRSM( 'L', 'L', 'N', DIAG, K, N, CONE, + + A( 0 ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'C' +* + CALL CTRSM( 'L', 'L', 'C', DIAG, K, N, ALPHA, + + A( 0 ), K, B( K, 0 ), LDB ) + CALL CGEMM( 'N', 'N', K, N, K, -CONE, + + A( K*( K+1 ) ), K, B( K, 0 ), LDB, + + ALPHA, B, LDB ) + CALL CTRSM( 'L', 'U', 'N', DIAG, K, N, CONE, + + A( K ), K, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'N' +* + CALL CTRSM( 'L', 'U', 'C', DIAG, K, N, ALPHA, + + A( K*( K+1 ) ), K, B, LDB ) + CALL CGEMM( 'N', 'N', K, N, K, -CONE, A( 0 ), K, B, + + LDB, ALPHA, B( K, 0 ), LDB ) + CALL CTRSM( 'L', 'L', 'N', DIAG, K, N, CONE, + + A( K*K ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'C' +* + CALL CTRSM( 'L', 'L', 'C', DIAG, K, N, ALPHA, + + A( K*K ), K, B( K, 0 ), LDB ) + CALL CGEMM( 'C', 'N', K, N, K, -CONE, A( 0 ), K, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL CTRSM( 'L', 'U', 'N', DIAG, K, N, CONE, + + A( K*( K+1 ) ), K, B, LDB ) +* + END IF +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' +* +* A is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and K. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + K = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* SIDE = 'R' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL CTRSM( 'R', 'U', 'C', DIAG, M, N2, ALPHA, + + A( N ), N, B( 0, N1 ), LDB ) + CALL CGEMM( 'N', 'N', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( N1 ), N, ALPHA, B( 0, 0 ), + + LDB ) + CALL CTRSM( 'R', 'L', 'N', DIAG, M, N1, CONE, + + A( 0 ), N, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'C' +* + CALL CTRSM( 'R', 'L', 'C', DIAG, M, N1, ALPHA, + + A( 0 ), N, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'C', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( N1 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL CTRSM( 'R', 'U', 'N', DIAG, M, N2, CONE, + + A( N ), N, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL CTRSM( 'R', 'L', 'C', DIAG, M, N1, ALPHA, + + A( N2 ), N, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'N', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( 0 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL CTRSM( 'R', 'U', 'N', DIAG, M, N2, CONE, + + A( N1 ), N, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'C' +* + CALL CTRSM( 'R', 'U', 'C', DIAG, M, N2, ALPHA, + + A( N1 ), N, B( 0, N1 ), LDB ) + CALL CGEMM( 'N', 'C', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) + CALL CTRSM( 'R', 'L', 'N', DIAG, M, N1, CONE, + + A( N2 ), N, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is odd, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'N' +* + CALL CTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( 1 ), N1, B( 0, N1 ), LDB ) + CALL CGEMM( 'N', 'C', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), + + LDB ) + CALL CTRSM( 'R', 'U', 'C', DIAG, M, N1, CONE, + + A( 0 ), N1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'C' +* + CALL CTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( 0 ), N1, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'N', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), + + LDB ) + CALL CTRSM( 'R', 'L', 'C', DIAG, M, N2, CONE, + + A( 1 ), N1, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'N' +* + CALL CTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'C', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), + + LDB ) + CALL CTRSM( 'R', 'L', 'C', DIAG, M, N2, CONE, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'C' +* + CALL CTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) + CALL CGEMM( 'N', 'N', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), + + LDB ) + CALL CTRSM( 'R', 'U', 'C', DIAG, M, N1, CONE, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL CTRSM( 'R', 'U', 'C', DIAG, M, K, ALPHA, + + A( 0 ), N+1, B( 0, K ), LDB ) + CALL CGEMM( 'N', 'N', M, K, K, -CONE, B( 0, K ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL CTRSM( 'R', 'L', 'N', DIAG, M, K, CONE, + + A( 1 ), N+1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'C' +* + CALL CTRSM( 'R', 'L', 'C', DIAG, M, K, ALPHA, + + A( 1 ), N+1, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'C', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL CTRSM( 'R', 'U', 'N', DIAG, M, K, CONE, + + A( 0 ), N+1, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL CTRSM( 'R', 'L', 'C', DIAG, M, K, ALPHA, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'N', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL CTRSM( 'R', 'U', 'N', DIAG, M, K, CONE, + + A( K ), N+1, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'C' +* + CALL CTRSM( 'R', 'U', 'C', DIAG, M, K, ALPHA, + + A( K ), N+1, B( 0, K ), LDB ) + CALL CGEMM( 'N', 'C', M, K, K, -CONE, B( 0, K ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL CTRSM( 'R', 'L', 'N', DIAG, M, K, CONE, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is even, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'N' +* + CALL CTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( 0 ), K, B( 0, K ), LDB ) + CALL CGEMM( 'N', 'C', M, K, K, -CONE, B( 0, K ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, 0 ), LDB ) + CALL CTRSM( 'R', 'U', 'C', DIAG, M, K, CONE, + + A( K ), K, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'C' +* + CALL CTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( K ), K, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'N', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, K ), LDB ) + CALL CTRSM( 'R', 'L', 'C', DIAG, M, K, CONE, + + A( 0 ), K, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'N' +* + CALL CTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) + CALL CGEMM( 'N', 'C', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) + CALL CTRSM( 'R', 'L', 'C', DIAG, M, K, CONE, + + A( K*K ), K, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'C' +* + CALL CTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( K*K ), K, B( 0, K ), LDB ) + CALL CGEMM( 'N', 'N', M, K, K, -CONE, B( 0, K ), + + LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) + CALL CTRSM( 'R', 'U', 'C', DIAG, M, K, CONE, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + END IF + END IF +* + RETURN +* +* End of CTFSM +* + END diff --git a/SRC/ctftri.f b/SRC/ctftri.f new file mode 100644 index 00000000..ffa0f014 --- /dev/null +++ b/SRC/ctftri.f @@ -0,0 +1,427 @@ + SUBROUTINE CTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO, DIAG + INTEGER INFO, N +* .. +* .. Array Arguments .. + COMPLEX A( 0: * ) +* .. +* +* Purpose +* ======= +* +* CTFTRI computes the inverse of a triangular matrix A stored in RFP +* format. +* +* This is a Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* DIAG (input) CHARACTER +* = 'N': A is non-unit triangular; +* = 'U': A is unit triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); +* On entry, the triangular matrix A in RFP format. RFP format +* is described by TRANSR, UPLO, and N as follows: If TRANSR = +* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is +* the Conjugate-transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A; If UPLO = 'L' the RFP A contains the nt +* elements of lower packed A. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is +* even and N is odd. See the Note below for more details. +* +* On exit, the (triangular) inverse of the original matrix, in +* the same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, A(i,i) is exactly zero. The triangular +* matrix is singular and its inverse can not be computed. +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX CONE + PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, CTRMM, CTRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL CTRTRI( 'L', DIAG, N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'L', 'N', DIAG, N2, N1, -CONE, A( 0 ), + + N, A( N1 ), N ) + CALL CTRTRI( 'U', DIAG, N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'U', 'C', DIAG, N2, N1, CONE, A( N ), N, + + A( N1 ), N ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL CTRTRI( 'L', DIAG, N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'L', 'C', DIAG, N1, N2, -CONE, A( N2 ), + + N, A( 0 ), N ) + CALL CTRTRI( 'U', DIAG, N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'U', 'N', DIAG, N1, N2, CONE, A( N1 ), + + N, A( 0 ), N ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) +* + CALL CTRTRI( 'U', DIAG, N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'U', 'N', DIAG, N1, N2, -CONE, A( 0 ), + + N1, A( N1*N1 ), N1 ) + CALL CTRTRI( 'L', DIAG, N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'L', 'C', DIAG, N1, N2, CONE, A( 1 ), + + N1, A( N1*N1 ), N1 ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) +* + CALL CTRTRI( 'U', DIAG, N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'U', 'C', DIAG, N2, N1, -CONE, + + A( N2*N2 ), N2, A( 0 ), N2 ) + CALL CTRTRI( 'L', DIAG, N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'L', 'N', DIAG, N2, N1, CONE, + + A( N1*N2 ), N2, A( 0 ), N2 ) + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL CTRTRI( 'L', DIAG, K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'L', 'N', DIAG, K, K, -CONE, A( 1 ), + + N+1, A( K+1 ), N+1 ) + CALL CTRTRI( 'U', DIAG, K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'U', 'C', DIAG, K, K, CONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL CTRTRI( 'L', DIAG, K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'L', 'C', DIAG, K, K, -CONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL CTRTRI( 'U', DIAG, K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'U', 'N', DIAG, K, K, CONE, A( K ), N+1, + + A( 0 ), N+1 ) + END IF + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL CTRTRI( 'U', DIAG, K, A( K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'U', 'N', DIAG, K, K, -CONE, A( K ), K, + + A( K*( K+1 ) ), K ) + CALL CTRTRI( 'L', DIAG, K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'L', 'C', DIAG, K, K, CONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL CTRTRI( 'U', DIAG, K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'R', 'U', 'C', DIAG, K, K, -CONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL CTRTRI( 'L', DIAG, K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL CTRMM( 'L', 'L', 'N', DIAG, K, K, CONE, A( K*K ), K, + + A( 0 ), K ) + END IF + END IF + END IF +* + RETURN +* +* End of CTFTRI +* + END diff --git a/SRC/ctfttp.f b/SRC/ctfttp.f new file mode 100644 index 00000000..4af92fd7 --- /dev/null +++ b/SRC/ctfttp.f @@ -0,0 +1,479 @@ + SUBROUTINE CTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + COMPLEX AP( 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* CTFTTP copies a triangular matrix A from rectangular full packed +* format (TF) to standard packed format (TP). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'C': ARF is in Conjugate-transpose format; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* .. Intrinsic Functions .. +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTFTTP', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + AP( 0 ) = ARF( 0 ) + ELSE + AP( 0 ) = CONJG( ARF( 0 ) ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + AP( IJP ) = CONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CTFTTP +* + END diff --git a/SRC/ctfttr.f b/SRC/ctfttr.f new file mode 100644 index 00000000..bc23d16d --- /dev/null +++ b/SRC/ctfttr.f @@ -0,0 +1,470 @@ + SUBROUTINE CTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + COMPLEX A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* CTFTTR copies a triangular matrix A from rectangular full packed +* format (TF) to standard full format (TR). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'C': ARF is in Conjugate-transpose format; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ARF (input) COMPLEX array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* A (output) COMPLEX array, dimension ( LDA, N ) +* On exit, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT, NX2, NP1X2 + INTEGER I, J, L, IJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTFTTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + A( 0, 0 ) = ARF( 0 ) + ELSE + A( 0, 0 ) = CONJG( ARF( 0 ) ) + END IF + END IF + RETURN + END IF +* +* Size of array ARF(1:2,0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + A( N2+J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + A( J-N1, L ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + A( J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + A( I, N1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + A( J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda = n2 +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + A( J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + A( N2+J, L ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + A( K+J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + A( J-K, L ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : +* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k +* + IJ = 0 + J = K + DO I = K, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + A( J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + A( I, K+1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + A( J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) +* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + A( J, I ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + A( K+1+J, L ) = CONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* +* Note that here J = K-1 +* + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CTFTTR +* + END diff --git a/SRC/ctgevc.f b/SRC/ctgevc.f index 0f98a65f..f39bb018 100644 --- a/SRC/ctgevc.f +++ b/SRC/ctgevc.f @@ -1,7 +1,7 @@ SUBROUTINE CTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctgex2.f b/SRC/ctgex2.f index 53726c63..57b59d29 100644 --- a/SRC/ctgex2.f +++ b/SRC/ctgex2.f @@ -1,7 +1,7 @@ SUBROUTINE CTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctgexc.f b/SRC/ctgexc.f index 750c649b..71b31c2a 100644 --- a/SRC/ctgexc.f +++ b/SRC/ctgexc.f @@ -1,7 +1,7 @@ SUBROUTINE CTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctgsen.f b/SRC/ctgsen.f index 371df1d2..cdb4807a 100644 --- a/SRC/ctgsen.f +++ b/SRC/ctgsen.f @@ -2,7 +2,7 @@ $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, $ WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/ctgsja.f b/SRC/ctgsja.f index 603b812c..8e9f9461 100644 --- a/SRC/ctgsja.f +++ b/SRC/ctgsja.f @@ -2,7 +2,7 @@ $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctgsna.f b/SRC/ctgsna.f index 71712573..30878194 100644 --- a/SRC/ctgsna.f +++ b/SRC/ctgsna.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctgsy2.f b/SRC/ctgsy2.f index 2824e0cd..95145f37 100644 --- a/SRC/ctgsy2.f +++ b/SRC/ctgsy2.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctgsyl.f b/SRC/ctgsyl.f index d08d3d1f..80f61d0c 100644 --- a/SRC/ctgsyl.f +++ b/SRC/ctgsyl.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/ctpcon.f b/SRC/ctpcon.f index 1954ef24..16bfff18 100644 --- a/SRC/ctpcon.f +++ b/SRC/ctpcon.f @@ -1,7 +1,7 @@ SUBROUTINE CTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctprfs.f b/SRC/ctprfs.f index d9cb2283..21ff4b21 100644 --- a/SRC/ctprfs.f +++ b/SRC/ctprfs.f @@ -1,7 +1,7 @@ SUBROUTINE CTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctptri.f b/SRC/ctptri.f index 3d63400c..afc49846 100644 --- a/SRC/ctptri.f +++ b/SRC/ctptri.f @@ -1,6 +1,6 @@ SUBROUTINE CTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctptrs.f b/SRC/ctptrs.f index 2471498e..529d7278 100644 --- a/SRC/ctptrs.f +++ b/SRC/ctptrs.f @@ -1,6 +1,6 @@ SUBROUTINE CTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctpttf.f b/SRC/ctpttf.f new file mode 100644 index 00000000..96cff67a --- /dev/null +++ b/SRC/ctpttf.f @@ -0,0 +1,476 @@ + SUBROUTINE CTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + COMPLEX AP( 0: * ), ARF( 0: * ) +* +* Purpose +* ======= +* +* CTPTTF copies a triangular matrix A from standard packed format (TP) +* to rectangular full packed format (TF). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal format is wanted; +* = 'C': ARF in Conjugate-transpose format is wanted. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* ARF (output) COMPLEX array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTPTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = AP( 0 ) + ELSE + ARF( 0 ) = CONJG( AP( 0 ) ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + ARF( IJ ) = CONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CTPTTF +* + END diff --git a/SRC/ctpttr.f b/SRC/ctpttr.f new file mode 100644 index 00000000..7e990f47 --- /dev/null +++ b/SRC/ctpttr.f @@ -0,0 +1,114 @@ + SUBROUTINE CTPTTR( UPLO, N, AP, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* CTPTTR copies a triangular matrix A from standard packed format (TP) +* to standard full format (TR). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular. +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) COMPLEX array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* A (output) COMPLEX array, dimension ( LDA, N ) +* On exit, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTPTTR', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + END IF +* +* + RETURN +* +* End of CTPTTR +* + END diff --git a/SRC/ctrcon.f b/SRC/ctrcon.f index 388db1c3..9b725163 100644 --- a/SRC/ctrcon.f +++ b/SRC/ctrcon.f @@ -1,7 +1,7 @@ SUBROUTINE CTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrevc.f b/SRC/ctrevc.f index bfc8011a..0c7ff122 100644 --- a/SRC/ctrevc.f +++ b/SRC/ctrevc.f @@ -1,7 +1,7 @@ SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrexc.f b/SRC/ctrexc.f index c6a450d3..55bc35a7 100644 --- a/SRC/ctrexc.f +++ b/SRC/ctrexc.f @@ -1,6 +1,6 @@ SUBROUTINE CTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrrfs.f b/SRC/ctrrfs.f index 8f7bb960..b48d888a 100644 --- a/SRC/ctrrfs.f +++ b/SRC/ctrrfs.f @@ -1,7 +1,7 @@ SUBROUTINE CTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrsen.f b/SRC/ctrsen.f index 085a6518..7f603b54 100644 --- a/SRC/ctrsen.f +++ b/SRC/ctrsen.f @@ -1,7 +1,7 @@ SUBROUTINE CTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrsna.f b/SRC/ctrsna.f index d098804d..37b1ab8f 100644 --- a/SRC/ctrsna.f +++ b/SRC/ctrsna.f @@ -2,7 +2,7 @@ $ LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrsyl.f b/SRC/ctrsyl.f index 6f0137ed..765c52d2 100644 --- a/SRC/ctrsyl.f +++ b/SRC/ctrsyl.f @@ -1,7 +1,7 @@ SUBROUTINE CTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrti2.f b/SRC/ctrti2.f index f9aa3241..11c46a82 100644 --- a/SRC/ctrti2.f +++ b/SRC/ctrti2.f @@ -1,6 +1,6 @@ SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrtri.f b/SRC/ctrtri.f index ffd2f6fa..de32204b 100644 --- a/SRC/ctrtri.f +++ b/SRC/ctrtri.f @@ -1,6 +1,6 @@ SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrtrs.f b/SRC/ctrtrs.f index fbb45d54..7e5f7061 100644 --- a/SRC/ctrtrs.f +++ b/SRC/ctrtrs.f @@ -1,7 +1,7 @@ SUBROUTINE CTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctrttf.f b/SRC/ctrttf.f new file mode 100644 index 00000000..3412536f --- /dev/null +++ b/SRC/ctrttf.f @@ -0,0 +1,469 @@ + SUBROUTINE CTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + COMPLEX A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* CTRTTF copies a triangular matrix A from standard full format (TR) +* to rectangular full packed format (TF) . +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal mode is wanted; +* = 'C': ARF in Conjugate Transpose mode is wanted; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX array, dimension ( LDA, N ) +* On entry, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the matrix A. LDA >= max(1,N). +* +* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = `N'. RFP holds AP as follows: +* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = `N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = `N'. RFP holds AP as follows: +* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = `N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CTRTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = A( 0, 0 ) + ELSE + ARF( 0 ) = CONJG( A( 0, 0 ) ) + END IF + END IF + RETURN + END IF +* +* Size of array ARF(1:2,0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + ARF( IJ ) = CONJG( A( N2+J, I ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + ARF( IJ ) = CONJG( A( J-N1, L ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + ARF( IJ ) = CONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + ARF( IJ ) = A( I, N1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + ARF( IJ ) = CONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda=n2 +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + ARF( IJ ) = CONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + ARF( IJ ) = CONJG( A( N2+J, L ) ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + ARF( IJ ) = CONJG( A( K+J, I ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + ARF( IJ ) = CONJG( A( J-K, L ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : +* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k +* + IJ = 0 + J = K + DO I = K, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = CONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + ARF( IJ ) = A( I, K+1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + ARF( IJ ) = CONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) +* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + ARF( IJ ) = CONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + ARF( IJ ) = CONJG( A( K+1+J, L ) ) + IJ = IJ + 1 + END DO + END DO +* +* Note that here J = K-1 +* + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of CTRTTF +* + END diff --git a/SRC/ctrttp.f b/SRC/ctrttp.f new file mode 100644 index 00000000..4bede256 --- /dev/null +++ b/SRC/ctrttp.f @@ -0,0 +1,114 @@ + SUBROUTINE CTRTTP( UPLO, N, A, LDA, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- and Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* CTRTTP copies a triangular matrix A from full format (TR) to standard +* packed format (TP). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrices AP and A. N >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* On entry, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AP (output) COMPLEX array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) 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( 'CTRTTP', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + END IF +* +* + RETURN +* +* End of CTRTTP +* + END diff --git a/SRC/ctzrqf.f b/SRC/ctzrqf.f index 923256a2..a196d0db 100644 --- a/SRC/ctzrqf.f +++ b/SRC/ctzrqf.f @@ -1,6 +1,6 @@ SUBROUTINE CTZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ctzrzf.f b/SRC/ctzrzf.f index 156b9941..4790f3fa 100644 --- a/SRC/ctzrzf.f +++ b/SRC/ctzrzf.f @@ -1,6 +1,6 @@ SUBROUTINE CTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cung2l.f b/SRC/cung2l.f index 1a253d63..c7db2877 100644 --- a/SRC/cung2l.f +++ b/SRC/cung2l.f @@ -1,6 +1,6 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cung2r.f b/SRC/cung2r.f index 9edfe64f..3f5a1070 100644 --- a/SRC/cung2r.f +++ b/SRC/cung2r.f @@ -1,6 +1,6 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungbr.f b/SRC/cungbr.f index 8814e850..a48051fb 100644 --- a/SRC/cungbr.f +++ b/SRC/cungbr.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunghr.f b/SRC/cunghr.f index d938d777..746b9933 100644 --- a/SRC/cunghr.f +++ b/SRC/cunghr.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungl2.f b/SRC/cungl2.f index 95ce84f9..2497bf6a 100644 --- a/SRC/cungl2.f +++ b/SRC/cungl2.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunglq.f b/SRC/cunglq.f index ecd5b65e..9db1040d 100644 --- a/SRC/cunglq.f +++ b/SRC/cunglq.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungql.f b/SRC/cungql.f index 88252096..14c2ac4b 100644 --- a/SRC/cungql.f +++ b/SRC/cungql.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungqr.f b/SRC/cungqr.f index b2337287..eb0a6ab6 100644 --- a/SRC/cungqr.f +++ b/SRC/cungqr.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungr2.f b/SRC/cungr2.f index a5f051a9..1d32d9dd 100644 --- a/SRC/cungr2.f +++ b/SRC/cungr2.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungrq.f b/SRC/cungrq.f index f40028ef..4aaf9104 100644 --- a/SRC/cungrq.f +++ b/SRC/cungrq.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cungtr.f b/SRC/cungtr.f index 4d424928..92a584e4 100644 --- a/SRC/cungtr.f +++ b/SRC/cungtr.f @@ -1,6 +1,6 @@ SUBROUTINE CUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunm2l.f b/SRC/cunm2l.f index fb33c410..934fcbc1 100644 --- a/SRC/cunm2l.f +++ b/SRC/cunm2l.f @@ -1,7 +1,7 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunm2r.f b/SRC/cunm2r.f index d54a1b2b..665831f4 100644 --- a/SRC/cunm2r.f +++ b/SRC/cunm2r.f @@ -1,7 +1,7 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmbr.f b/SRC/cunmbr.f index 6212f125..e0ac0e6a 100644 --- a/SRC/cunmbr.f +++ b/SRC/cunmbr.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmhr.f b/SRC/cunmhr.f index 11646ef5..57b56f84 100644 --- a/SRC/cunmhr.f +++ b/SRC/cunmhr.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunml2.f b/SRC/cunml2.f index 09a5ad0e..2657737b 100644 --- a/SRC/cunml2.f +++ b/SRC/cunml2.f @@ -1,7 +1,7 @@ SUBROUTINE CUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmlq.f b/SRC/cunmlq.f index cc2018de..0b3ef69c 100644 --- a/SRC/cunmlq.f +++ b/SRC/cunmlq.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmql.f b/SRC/cunmql.f index eeb23422..f69adbca 100644 --- a/SRC/cunmql.f +++ b/SRC/cunmql.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmqr.f b/SRC/cunmqr.f index 152c4c5d..02efd411 100644 --- a/SRC/cunmqr.f +++ b/SRC/cunmqr.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmr2.f b/SRC/cunmr2.f index 3dc0cb47..667192b6 100644 --- a/SRC/cunmr2.f +++ b/SRC/cunmr2.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmr3.f b/SRC/cunmr3.f index 3660fbac..191183fe 100644 --- a/SRC/cunmr3.f +++ b/SRC/cunmr3.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmrq.f b/SRC/cunmrq.f index e8a83f17..1ec0ac65 100644 --- a/SRC/cunmrq.f +++ b/SRC/cunmrq.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cunmrz.f b/SRC/cunmrz.f index 041043cc..b8161f50 100644 --- a/SRC/cunmrz.f +++ b/SRC/cunmrz.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/cunmtr.f b/SRC/cunmtr.f index 3c601975..97aabb31 100644 --- a/SRC/cunmtr.f +++ b/SRC/cunmtr.f @@ -1,7 +1,7 @@ SUBROUTINE CUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cupgtr.f b/SRC/cupgtr.f index 490b5c15..cb7d6ffc 100644 --- a/SRC/cupgtr.f +++ b/SRC/cupgtr.f @@ -1,6 +1,6 @@ SUBROUTINE CUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/cupmtr.f b/SRC/cupmtr.f index de09b783..6f8a4c07 100644 --- a/SRC/cupmtr.f +++ b/SRC/cupmtr.f @@ -1,7 +1,7 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dbdsdc.f b/SRC/dbdsdc.f index 2bd3de62..c625d9e9 100644 --- a/SRC/dbdsdc.f +++ b/SRC/dbdsdc.f @@ -1,7 +1,7 @@ SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dbdsqr.f b/SRC/dbdsqr.f index 60245862..472e00e1 100644 --- a/SRC/dbdsqr.f +++ b/SRC/dbdsqr.f @@ -1,7 +1,7 @@ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * @@ -105,16 +105,23 @@ * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * -* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) -* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: If INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm did not converge; D and E contain the -* elements of a bidiagonal matrix which is orthogonally -* similar to the input matrix B; if INFO = i, i -* elements of E have not converged to zero. +* > 0: +* if NCVT = NRU = NCC = 0, +* = 1, a split was marked by a positive value in E +* = 2, current block of Z not diagonalized after 30*N +* iterations (in inner while loop) +* = 3, termination criterion of outer while loop not met +* (program created more than N unreduced blocks) +* else NCVT = NRU = NCC = 0, +* the algorithm did not converge; D and E contain the +* elements of a bidiagonal matrix which is orthogonally +* similar to the input matrix B; if INFO = i, i +* elements of E have not converged to zero. * * Internal Parameters * =================== diff --git a/SRC/ddisna.f b/SRC/ddisna.f index 2d9ed334..74a5e1ca 100644 --- a/SRC/ddisna.f +++ b/SRC/ddisna.f @@ -1,6 +1,6 @@ SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbbrd.f b/SRC/dgbbrd.f index 5b8f06fb..3a43bd0f 100644 --- a/SRC/dgbbrd.f +++ b/SRC/dgbbrd.f @@ -1,7 +1,7 @@ SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbcon.f b/SRC/dgbcon.f index b75d6784..c961d307 100644 --- a/SRC/dgbcon.f +++ b/SRC/dgbcon.f @@ -1,7 +1,7 @@ SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbequ.f b/SRC/dgbequ.f index e813761f..5166d95b 100644 --- a/SRC/dgbequ.f +++ b/SRC/dgbequ.f @@ -1,7 +1,7 @@ SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbequb.f b/SRC/dgbequb.f new file mode 100644 index 00000000..57a6aafe --- /dev/null +++ b/SRC/dgbequb.f @@ -0,0 +1,261 @@ + SUBROUTINE DGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) +* .. +* +* Purpose +* ======= +* +* DGBEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from DGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* LDAB (input) INTEGER +* The leading dimension of the array A. LDAB >= max(1,M). +* +* R (output) DOUBLE PRECISION array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) DOUBLE PRECISION +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) DOUBLE PRECISION +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = DLAMCH( 'B' ) + LOGRDX = LOG(RADIX) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + KD = KU + 1 + DO 30 J = 1, N + DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of DGBEQUB +* + END diff --git a/SRC/dgbrfs.f b/SRC/dgbrfs.f index c466f5a7..4ae8fe7b 100644 --- a/SRC/dgbrfs.f +++ b/SRC/dgbrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbrfsx.f b/SRC/dgbrfsx.f new file mode 100644 index 00000000..ca508300 --- /dev/null +++ b/SRC/dgbrfsx.f @@ -0,0 +1,628 @@ + SUBROUTINE DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, + $ NPARAMS, N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DGBRFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* The original band matrix A, stored in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) +* Details of the LU factorization of the band matrix A, as +* computed by DGBTRF. U is stored as an upper triangular band +* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +* the multipliers used during the factorization are stored in +* rows KL+KU+2 to 2*KL+KU+1. +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 100.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGBCON + EXTERNAL DLA_GBRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, DLANGB, DLA_GBRCOND + DOUBLE PRECISION DLAMCH, DLANGB, DLA_GBRCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) + CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF (REF_TYPE .NE. 0) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + IF ( NOTRAN ) THEN + CALL DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), + $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + ELSE + CALL DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), + $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, -1, C, INFO, WORK, IWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, -1, R, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, 0, R, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, 1, X( 1, J ), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of DGBRFSX +* + END diff --git a/SRC/dgbsv.f b/SRC/dgbsv.f index 1629ec79..a4226fce 100644 --- a/SRC/dgbsv.f +++ b/SRC/dgbsv.f @@ -1,6 +1,6 @@ SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbsvx.f b/SRC/dgbsvx.f index a329ec22..0f1bf5b3 100644 --- a/SRC/dgbsvx.f +++ b/SRC/dgbsvx.f @@ -2,7 +2,7 @@ $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbsvxx.f b/SRC/dgbsvxx.f new file mode 100644 index 00000000..cb29b2e4 --- /dev/null +++ b/SRC/dgbsvxx.f @@ -0,0 +1,654 @@ + SUBROUTINE DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, + $ RCOND, RPVGRW, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DGBSVXX uses the LU factorization to compute the solution to a +* double precision system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. DGBSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* DGBSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* DGBSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what DGBSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose = Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* If FACT = 'F' and EQUED is not 'N', then AB must have been +* equilibrated by the scaling factors in R and/or C. AB is not +* modified if FACT = 'F' or 'N', or if FACT = 'E' and +* EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) +* If FACT = 'F', then AFB is an input argument and on entry +* contains details of the LU factorization of the band matrix +* A, as computed by DGBTRF. U is stored as an upper triangular +* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +* and the multipliers used during the factorization are stored +* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is +* the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by DGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In DGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, I, J, KL, KU + DOUBLE PRECISION AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_GBRPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DGBEQUB, DGBTRF, DGBTRS, DLACPY, DLAQGB, + $ XERBLA, DLASCL2, DGBRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DGBRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DGBRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -12 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -13 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -14 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGBSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DGBEQUB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0D+0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0D+0 + END DO + END IF + END IF +* +* Scale the right hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL DLASCL2(N, NRHS, R, B, LDB) + ELSE + IF( COLEQU ) CALL DLASCL2(N, NRHS, C, B, LDB) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + DO 40, J = 1, N + DO 30, I = KL+1, 2*KL+KU+1 + AFB( I, J ) = AB( I-KL, J ) + 30 CONTINUE + 40 CONTINUE + CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLA_GBRPVGRW( N, KL, KU, INFO, AB, LDAB, AFB, + $ LDAFB ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = DLA_GBRPVGRW( N, KL, KU, N, AB, LDAB, AFB, LDAFB ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of DGBSVXX +* + END diff --git a/SRC/dgbtf2.f b/SRC/dgbtf2.f index 929829e8..7a118dd7 100644 --- a/SRC/dgbtf2.f +++ b/SRC/dgbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbtrf.f b/SRC/dgbtrf.f index b22fc065..f19115e3 100644 --- a/SRC/dgbtrf.f +++ b/SRC/dgbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgbtrs.f b/SRC/dgbtrs.f index c7ade372..06b366a0 100644 --- a/SRC/dgbtrs.f +++ b/SRC/dgbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgebak.f b/SRC/dgebak.f index b8e9be56..4a491e62 100644 --- a/SRC/dgebak.f +++ b/SRC/dgebak.f @@ -1,7 +1,7 @@ SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgebal.f b/SRC/dgebal.f index 1796577b..8d4cb3c6 100644 --- a/SRC/dgebal.f +++ b/SRC/dgebal.f @@ -1,6 +1,6 @@ SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgebd2.f b/SRC/dgebd2.f index b9eb6387..d91282f3 100644 --- a/SRC/dgebd2.f +++ b/SRC/dgebd2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgebrd.f b/SRC/dgebrd.f index 6544715d..5b0f7e3b 100644 --- a/SRC/dgebrd.f +++ b/SRC/dgebrd.f @@ -1,7 +1,7 @@ SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgecon.f b/SRC/dgecon.f index 807cafca..c7132f69 100644 --- a/SRC/dgecon.f +++ b/SRC/dgecon.f @@ -1,7 +1,7 @@ SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeequ.f b/SRC/dgeequ.f index b703116e..7526a656 100644 --- a/SRC/dgeequ.f +++ b/SRC/dgeequ.f @@ -1,7 +1,7 @@ SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeequb.f b/SRC/dgeequb.f new file mode 100644 index 00000000..5d748e78 --- /dev/null +++ b/SRC/dgeequb.f @@ -0,0 +1,248 @@ + SUBROUTINE DGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) +* .. +* +* Purpose +* ======= +* +* DGEEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from DGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The M-by-N matrix whose equilibration factors are +* to be computed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* R (output) DOUBLE PRECISION array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) DOUBLE PRECISION +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) DOUBLE PRECISION +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = DLAMCH( 'B' ) + LOGRDX = LOG( RADIX ) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + DO 30 J = 1, N + DO 20 I = 1, M + R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = 1, M + C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of DGEEQUB +* + END diff --git a/SRC/dgees.f b/SRC/dgees.f index 96ba8019..099ca355 100644 --- a/SRC/dgees.f +++ b/SRC/dgees.f @@ -1,7 +1,7 @@ SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeesx.f b/SRC/dgeesx.f index deb30ab2..35024ddc 100644 --- a/SRC/dgeesx.f +++ b/SRC/dgeesx.f @@ -2,7 +2,7 @@ $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeev.f b/SRC/dgeev.f index 50e08a9c..7b049809 100644 --- a/SRC/dgeev.f +++ b/SRC/dgeev.f @@ -1,7 +1,7 @@ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeevx.f b/SRC/dgeevx.f index 7d927ae9..514e28ad 100644 --- a/SRC/dgeevx.f +++ b/SRC/dgeevx.f @@ -2,7 +2,7 @@ $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgegs.f b/SRC/dgegs.f index 85c32531..7a2375c0 100644 --- a/SRC/dgegs.f +++ b/SRC/dgegs.f @@ -2,7 +2,7 @@ $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgegv.f b/SRC/dgegv.f index 282fdb99..6bb22c7c 100644 --- a/SRC/dgegv.f +++ b/SRC/dgegv.f @@ -1,7 +1,7 @@ SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgehd2.f b/SRC/dgehd2.f index 28d1cc8d..5c0a3597 100644 --- a/SRC/dgehd2.f +++ b/SRC/dgehd2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgehrd.f b/SRC/dgehrd.f index 339ee400..4ad82246 100644 --- a/SRC/dgehrd.f +++ b/SRC/dgehrd.f @@ -1,6 +1,6 @@ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgejsv.f b/SRC/dgejsv.f new file mode 100644 index 00000000..28efa5f2 --- /dev/null +++ b/SRC/dgejsv.f @@ -0,0 +1,1653 @@ + SUBROUTINE DGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, + & M, N, A, LDA, SVA, U, LDU, V, LDV, + & WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* -#- Scalar Arguments -#- +* + IMPLICIT NONE + INTEGER INFO, LDA, LDU, LDV, LWORK, M, N +* +* -#- Array Arguments -#- +* + DOUBLE PRECISION A( LDA, * ), SVA( N ), U( LDU, * ), V( LDV, * ), + & WORK( LWORK ) + INTEGER IWORK( * ) + CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV +* .. +* +* Purpose +* ~~~~~~~ +* DGEJSV computes the singular value decomposition (SVD) of a real M-by-N +* matrix [A], where M >= N. The SVD of [A] is written as +* +* [A] = [U] * [SIGMA] * [V]^t, +* +* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N +* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and +* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are +* the singular values of [A]. The columns of [U] and [V] are the left and +* the right singular vectors of [A], respectively. The matrices [U] and [V] +* are computed and stored in the arrays U and V, respectively. The diagonal +* of [SIGMA] is computed and stored in the array SVA. +* +* Further details +* ~~~~~~~~~~~~~~~ +* DGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3, +* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an +* additional row pivoting can be used as a preprocessor, which in some +* cases results in much higher accuracy. An example is matrix A with the +* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned +* diagonal matrices and C is well-conditioned matrix. In that case, complete +* pivoting in the first QR factorizations provides accuracy dependent on the +* condition number of C, and independent of D1, D2. Such higher accuracy is +* not completely understood theoretically, but it works well in practice. +* Further, if A can be written as A = B*D, with well-conditioned B and some +* diagonal D, then the high accuracy is guaranteed, both theoretically and +* in software, independent of D. For more details see [1], [2]. +* The computational range for the singular values can be the full range +* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS +* & LAPACK routines called by DGEJSV are implemented to work in that range. +* If that is not the case, then the restriction for safe computation with +* the singular values in the range of normalized IEEE numbers is that the +* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not +* overflow. This code (DGEJSV) is best used in this restricted range, +* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are +* returned as zeros. See JOBR for details on this. +* Further, this implementation is somewhat slower than the one described +* in [1,2] due to replacement of some non-LAPACK components, and because +* the choice of some tuning parameters in the iterative part (DGESVJ) is +* left to the implementer on a particular machine. +* The rank revealing QR factorization (in this code: SGEQP3) should be +* implemented as in [3]. We have a new version of SGEQP3 under development +* that is more robust than the current one in LAPACK, with a cleaner cut in +* rank defficient cases. It will be available in the SIGMA library [4]. +* If M is much larger than N, it is obvious that the inital QRF with +* column pivoting can be preprocessed by the QRF without pivoting. That +* well known trick is not used in DGEJSV because in some cases heavy row +* weighting can be treated with complete pivoting. The overhead in cases +* M much larger than N is then only due to pivoting, but the benefits in +* terms of accuracy have prevailed. The implementer/user can incorporate +* this extra QRF step easily. The implementer can also improve data movement +* (matrix transpose, matrix copy, matrix transposed copy) - this +* implementation of DGEJSV uses only the simplest, naive data movement. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* References +* ~~~~~~~~~~ +* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +* LAPACK Working note 169. +* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +* LAPACK Working note 170. +* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR +* factorization software - a case study. +* ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. +* LAPACK Working note 176. +* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +* QSVD, (H,K)-SVD computations. +* Department of Mathematics, University of Zagreb, 2008. +* +* Bugs, examples and comments +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Please report all bugs and send interesting examples and/or comments to +* drmac@math.hr. Thank you. +* +* Arguments +* ~~~~~~~~~ +*............................................................................ +*. JOBA (input) CHARACTER*1 +*. Specifies the level of accuracy: +*. = 'C': This option works well (high relative accuracy) if A = B * D, +*. with well-conditioned B and arbitrary diagonal matrix D. +*. The accuracy cannot be spoiled by COLUMN scaling. The +*. accuracy of the computed output depends on the condition of +*. B, and the procedure aims at the best theoretical accuracy. +*. The relative error max_{i=1:N}|d sigma_i| / sigma_i is +*. bounded by f(M,N)*epsilon* cond(B), independent of D. +*. The input matrix is preprocessed with the QRF with column +*. pivoting. This initial preprocessing and preconditioning by +*. a rank revealing QR factorization is common for all values of +*. JOBA. Additional actions are specified as follows: +*. = 'E': Computation as with 'C' with an additional estimate of the +*. condition number of B. It provides a realistic error bound. +*. = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings +*. D1, D2, and well-conditioned matrix C, this option gives +*. higher accuracy than the 'C' option. If the structure of the +*. input matrix is not known, and relative accuracy is +*. desirable, then this option is advisable. The input matrix A +*. is preprocessed with QR factorization with FULL (row and +*. column) pivoting. +*. = 'G' Computation as with 'F' with an additional estimate of the +*. condition number of B, where A=D*B. If A has heavily weighted +*. rows, then using this condition number gives too pessimistic +*. error bound. +*. = 'A': Small singular values are the noise and the matrix is treated +*. as numerically rank defficient. The error in the computed +*. singular values is bounded by f(m,n)*epsilon*||A||. +*. The computed SVD A = U * S * V^t restores A up to +*. f(m,n)*epsilon*||A||. +*. This gives the procedure the licence to discard (set to zero) +*. all singular values below N*epsilon*||A||. +*. = 'R': Similar as in 'A'. Rank revealing property of the initial +*. QR factorization is used do reveal (using triangular factor) +*. a gap sigma_{r+1} < epsilon * sigma_r in which case the +*. numerical RANK is declared to be r. The SVD is computed with +*. absolute error bounds, but more accurately than with 'A'. +*. +*. JOBU (input) CHARACTER*1 +*. Specifies whether to compute the columns of U: +*. = 'U': N columns of U are returned in the array U. +*. = 'F': full set of M left sing. vectors is returned in the array U. +*. = 'W': U may be used as workspace of length M*N. See the description +*. of U. +*. = 'N': U is not computed. +*. +*. JOBV (input) CHARACTER*1 +*. Specifies whether to compute the matrix V: +*. = 'V': N columns of V are returned in the array V; Jacobi rotations +*. are not explicitly accumulated. +*. = 'J': N columns of V are returned in the array V, but they are +*. computed as the product of Jacobi rotations. This option is +*. allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. +*. = 'W': V may be used as workspace of length N*N. See the description +*. of V. +*. = 'N': V is not computed. +*. +*. JOBR (input) CHARACTER*1 +*. Specifies the RANGE for the singular values. Issues the licence to +*. set to zero small positive singular values if they are outside +*. specified range. If A .NE. 0 is scaled so that the largest singular +*. value of c*A is around DSQRT(BIG), BIG=SLAMCH('O'), then JOBR issues +*. the licence to kill columns of A whose norm in c*A is less than +*. DSQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, +*. where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). +*. = 'N': Do not kill small columns of c*A. This option assumes that +*. BLAS and QR factorizations and triangular solvers are +*. implemented to work in that range. If the condition of A +*. is greater than BIG, use DGESVJ. +*. = 'R': RESTRICTED range for sigma(c*A) is [DSQRT(SFMIN), DSQRT(BIG)] +*. (roughly, as described above). This option is recommended. +*. ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*. For computing the singular values in the FULL range [SFMIN,BIG] +*. use DGESVJ. +*. +*. JOBT (input) CHARACTER*1 +*. If the matrix is square then the procedure may determine to use +*. transposed A if A^t seems to be better with respect to convergence. +*. If the matrix is not square, JOBT is ignored. This is subject to +*. changes in the future. +*. The decision is based on two values of entropy over the adjoint +*. orbit of A^t * A. See the descriptions of WORK(6) and WORK(7). +*. = 'T': transpose if entropy test indicates possibly faster +*. convergence of Jacobi process if A^t is taken as input. If A is +*. replaced with A^t, then the row pivoting is included automatically. +*. = 'N': do not speculate. +*. This option can be used to compute only the singular values, or the +*. full SVD (U, SIGMA and V). For only one set of singular vectors +*. (U or V), the caller should provide both U and V, as one of the +*. matrices is used as workspace if the matrix A is transposed. +*. The implementer can easily remove this constraint and make the +*. code more complicated. See the descriptions of U and V. +*. +*. JOBP (input) CHARACTER*1 +*. Issues the licence to introduce structured perturbations to drown +*. denormalized numbers. This licence should be active if the +*. denormals are poorly implemented, causing slow computation, +*. especially in cases of fast convergence (!). For details see [1,2]. +*. For the sake of simplicity, this perturbations are included only +*. when the full SVD or only the singular values are requested. The +*. implementer/user can easily add the perturbation for the cases of +*. computing one set of singular vectors. +*. = 'P': introduce perturbation +*. = 'N': do not perturb +*............................................................................ +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. M >= N >= 0. +* +* A (input/workspace) REAL array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* SVA (workspace/output) REAL array, dimension (N) +* On exit, +* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the +* computation SVA contains Euclidean column norms of the +* iterated matrices in the array A. +* - For WORK(1) .NE. WORK(2): The singular values of A are +* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if +* sigma_max(A) overflows or if small singular values have been +* saved from underflow by scaling the input matrix A. +* - If JOBR='R' then some of the singular values may be returned +* as exact zeros obtained by "set to zero" because they are +* below the numerical rank threshold or are denormalized numbers. +* +* U (workspace/output) REAL array, dimension ( LDU, N ) +* If JOBU = 'U', then U contains on exit the M-by-N matrix of +* the left singular vectors. +* If JOBU = 'F', then U contains on exit the M-by-M matrix of +* the left singular vectors, including an ONB +* of the orthogonal complement of the Range(A). +* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), +* then U is used as workspace if the procedure +* replaces A with A^t. In that case, [V] is computed +* in U as left singular vectors of A^t and then +* copied back to the V array. This 'W' option is just +* a reminder to the caller that in this case U is +* reserved as workspace of length N*N. +* If JOBU = 'N' U is not referenced. +* +* LDU (input) INTEGER +* The leading dimension of the array U, LDU >= 1. +* IF JOBU = 'U' or 'F' or 'W', then LDU >= M. +* +* V (workspace/output) REAL array, dimension ( LDV, N ) +* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of +* the right singular vectors; +* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), +* then V is used as workspace if the pprocedure +* replaces A with A^t. In that case, [U] is computed +* in V as right singular vectors of A^t and then +* copied back to the U array. This 'W' option is just +* a reminder to the caller that in this case V is +* reserved as workspace of length N*N. +* If JOBV = 'N' V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV >= 1. +* If JOBV = 'V' or 'J' or 'W', then LDV >= N. +* +* WORK (workspace/output) REAL array, dimension at least LWORK. +* On exit, +* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such +* that SCALE*SVA(1:N) are the computed singular values +* of A. (See the description of SVA().) +* WORK(2) = See the description of WORK(1). +* WORK(3) = SCONDA is an estimate for the condition number of +* column equilibrated A. (If JOBA .EQ. 'E' or 'G') +* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1). +* It is computed using DPOCON. It holds +* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA +* where R is the triangular factor from the QRF of A. +* However, if R is truncated and the numerical rank is +* determined to be strictly smaller than N, SCONDA is +* returned as -1, thus indicating that the smallest +* singular values might be lost. +* +* If full SVD is needed, the following two condition numbers are +* useful for the analysis of the algorithm. They are provied for +* a developer/implementer who is familiar with the details of +* the method. +* +* WORK(4) = an estimate of the scaled condition number of the +* triangular factor in the first QR factorization. +* WORK(5) = an estimate of the scaled condition number of the +* triangular factor in the second QR factorization. +* The following two parameters are computed if JOBT .EQ. 'T'. +* They are provided for a developer/implementer who is familiar +* with the details of the method. +* +* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy +* of diag(A^t*A) / Trace(A^t*A) taken as point in the +* probability simplex. +* WORK(7) = the entropy of A*A^t. +* +* LWORK (input) INTEGER +* Length of WORK to confirm proper allocation of work space. +* LWORK depends on the job: +* +* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and +* -> .. no scaled condition estimate required ( JOBE.EQ.'N'): +* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement. +* For optimal performance (blocked code) the optimal value +* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal +* block size for xGEQP3/xGEQRF. +* -> .. an estimate of the scaled condition number of A is +* required (JOBA='E', 'G'). In this case, LWORK is the maximum +* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7). +* +* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), +* -> the minimal requirement is LWORK >= max(2*N+M,7). +* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), +* where NB is the optimal block size. +* +* If SIGMA and the left singular vectors are needed +* -> the minimal requirement is LWORK >= max(2*N+M,7). +* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), +* where NB is the optimal block size. +* +* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and +* -> .. the singular vectors are computed without explicit +* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N +* -> .. in the iterative part, the Jacobi rotations are +* explicitly accumulated (option, see the description of JOBV), +* then the minimal requirement is LWORK >= max(M+3*N+N*N,7). +* For better performance, if NB is the optimal block size, +* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7). +* +* IWORK (workspace/output) INTEGER array, dimension M+3*N. +* On exit, +* IWORK(1) = the numerical rank determined after the initial +* QR factorization with pivoting. See the descriptions +* of JOBA and JOBR. +* IWORK(2) = the number of the computed nonzero singular values +* IWORK(3) = if nonzero, a warning message: +* If IWORK(3).EQ.1 then some of the column norms of A +* were denormalized floats. The requested high accuracy +* is not warranted by the data. +* +* INFO (output) INTEGER +* < 0 : if INFO = -i, then the i-th argument had an illegal value. +* = 0 : successfull exit; +* > 0 : DGEJSV did not converge in the maximal allowed number +* of sweeps. The computed values may be inaccurate. +* +*............................................................................ +* +* Local Parameters: +* + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* +* Local Scalars: +* + DOUBLE PRECISION AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK, + & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM, + & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC + INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING + LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC, + & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, + & NOSCAL, ROWPIV, RSVEC, TRANSP +* +* Intrinsic Functions: +* + INTRINSIC DABS, DLOG, DMAX1, DMIN1, DBLE, + & MAX0, MIN0, IDNINT, DSIGN, DSQRT +* +* External Functions: +* + DOUBLE PRECISION DLAMCH, DNRM2 + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME, DLAMCH, DNRM2 +* +* External Subroutines ( BLAS, LAPACK ): +* + EXTERNAL DCOPY, DGELQF, DGEQP3, DGEQRF, DLACPY, DLASCL, + & DLASET, DLASSQ, DLASWP, DORGQR, DORMLQ, + & DORMQR, DPOCON, DSCAL, DSWAP, DTRSM, XERBLA +* + EXTERNAL DGESVJ +* +*............................................................................ +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) + JRACC = LSAME( JOBV, 'J' ) + RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC + ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) + L2RANK = LSAME( JOBA, 'R' ) + L2ABER = LSAME( JOBA, 'A' ) + ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) + L2TRAN = LSAME( JOBT, 'T' ) + L2KILL = LSAME( JOBR, 'R' ) + DEFR = LSAME( JOBR, 'N' ) + L2PERT = LSAME( JOBP, 'P' ) +* + IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. + & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN + INFO = - 1 + ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. + & LSAME( JOBU, 'W' )) ) THEN + INFO = - 2 + ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. + & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN + INFO = - 3 + ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN + INFO = - 4 + ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN + INFO = - 5 + ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN + INFO = - 6 + ELSE IF ( M .LT. 0 ) THEN + INFO = - 7 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN + INFO = - 8 + ELSE IF ( LDA .LT. M ) THEN + INFO = - 10 + ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN + INFO = - 13 + ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN + INFO = - 14 + ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. + & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR. + & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND. + & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR. + & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR. + & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR. + & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N)) + & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N))) + & THEN + INFO = - 17 + ELSE +* #:) + INFO = 0 + END IF +* + IF ( INFO .NE. 0 ) THEN +* #:( + CALL XERBLA( 'DGEJSV', - INFO ) + END IF +* +* Quick return for void matrix (Y3K safe) +* #:) + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN +* +* Determine whether the matrix U should be M x N or M x M +* + IF ( LSVEC ) THEN + N1 = N + IF ( LSAME( JOBU, 'F' ) ) N1 = M + END IF +* +* Set numerical parameters +* +*! NOTE: Make sure DLAMCH() does not fail on the target architecture. +* + + EPSLN = DLAMCH('Epsilon') + SFMIN = DLAMCH('SafeMinimum') + SMALL = SFMIN / EPSLN + BIG = DLAMCH('O') +* BIG = ONE / SFMIN +* +* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N +* +*(!) If necessary, scale SVA() to protect the largest norm from +* overflow. It is possible that this scaling pushes the smallest +* column norm left from the underflow threshold (extreme case). +* + SCALEM = ONE / DSQRT(DBLE(M)*DBLE(N)) + NOSCAL = .TRUE. + GOSCAL = .TRUE. + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 9 + CALL XERBLA( 'DGEJSV', -INFO ) + RETURN + END IF + AAQQ = DSQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCAL = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALEM ) + IF ( GOSCAL ) THEN + GOSCAL = .FALSE. + CALL DSCAL( p-1, SCALEM, SVA, 1 ) + END IF + END IF + 1874 CONTINUE +* + IF ( NOSCAL ) SCALEM = ONE +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + AAPP = DMAX1( AAPP, SVA(p) ) + IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) ) + 4781 CONTINUE +* +* Quick return for zero M x N matrix +* #:) + IF ( AAPP .EQ. ZERO ) THEN + IF ( LSVEC ) CALL DLASET( 'G', M, N1, ZERO, ONE, U, LDU ) + IF ( RSVEC ) CALL DLASET( 'G', N, N, ZERO, ONE, V, LDV ) + WORK(1) = ONE + WORK(2) = ONE + IF ( ERREST ) WORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + WORK(4) = ONE + WORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + WORK(6) = ZERO + WORK(7) = ZERO + END IF + IWORK(1) = 0 + IWORK(2) = 0 + RETURN + END IF +* +* Issue warning if denormalized column norms detected. Override the +* high relative accuracy request. Issue licence to kill columns +* (set them to zero) whose norm is less than sigma_max / BIG (roughly). +* #:( + WARNING = 0 + IF ( AAQQ .LE. SFMIN ) THEN + L2RANK = .TRUE. + L2KILL = .TRUE. + WARNING = 1 + END IF +* +* Quick return for one-column matrix +* #:) + IF ( N .EQ. 1 ) THEN +* + IF ( LSVEC ) THEN + CALL DLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) + CALL DLACPY( 'A', M, 1, A, LDA, U, LDU ) +* computing all M left singular vectors of the M x 1 matrix + IF ( N1 .NE. N ) THEN + CALL DGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR ) + CALL DORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR ) + CALL DCOPY( M, A(1,1), 1, U(1,1), 1 ) + END IF + END IF + IF ( RSVEC ) THEN + V(1,1) = ONE + END IF + IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN + SVA(1) = SVA(1) / SCALEM + SCALEM = ONE + END IF + WORK(1) = ONE / SCALEM + WORK(2) = ONE + IF ( SVA(1) .NE. ZERO ) THEN + IWORK(1) = 1 + IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN + IWORK(2) = 1 + ELSE + IWORK(2) = 0 + END IF + ELSE + IWORK(1) = 0 + IWORK(2) = 0 + END IF + IF ( ERREST ) WORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + WORK(4) = ONE + WORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + WORK(6) = ZERO + WORK(7) = ZERO + END IF + RETURN +* + END IF +* + TRANSP = .FALSE. + L2TRAN = L2TRAN .AND. ( M .EQ. N ) +* + AATMAX = -ONE + AATMIN = BIG + IF ( ROWPIV .OR. L2TRAN ) THEN +* +* Compute the row norms, needed to determine row pivoting sequence +* (in the case of heavily row weighted A, row pivoting is strongly +* advised) and to collect information needed to compare the +* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.). +* + IF ( L2TRAN ) THEN + DO 1950 p = 1, M + XSC = ZERO + TEMP1 = ZERO + CALL DLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) +* DLASSQ gets both the ell_2 and the ell_infinity norm +* in one pass through the vector + WORK(M+N+p) = XSC * SCALEM + WORK(N+p) = XSC * (SCALEM*DSQRT(TEMP1)) + AATMAX = DMAX1( AATMAX, WORK(N+p) ) + IF (WORK(N+p) .NE. ZERO) AATMIN = DMIN1(AATMIN,WORK(N+p)) + 1950 CONTINUE + ELSE + DO 1904 p = 1, M + WORK(M+N+p) = SCALEM*DABS( A(p,IDAMAX(N,A(p,1),LDA)) ) + AATMAX = DMAX1( AATMAX, WORK(M+N+p) ) + AATMIN = DMIN1( AATMIN, WORK(M+N+p) ) + 1904 CONTINUE + END IF +* + END IF +* +* For square matrix A try to determine whether A^t would be better +* input for the preconditioned Jacobi SVD, with faster convergence. +* The decision is based on an O(N) function of the vector of column +* and row norms of A, based on the Shannon entropy. This should give +* the right choice in most cases when the difference actually matters. +* It may fail and pick the slower converging side. +* + ENTRA = ZERO + ENTRAT = ZERO + IF ( L2TRAN ) THEN +* + XSC = ZERO + TEMP1 = ZERO + CALL DLASSQ( N, SVA, 1, XSC, TEMP1 ) + TEMP1 = ONE / TEMP1 +* + ENTRA = ZERO + DO 1113 p = 1, N + BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * DLOG(BIG1) + 1113 CONTINUE + ENTRA = - ENTRA / DLOG(DBLE(N)) +* +* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex. +* It is derived from the diagonal of A^t * A. Do the same with the +* diagonal of A * A^t, compute the entropy of the corresponding +* probability distribution. Note that A * A^t and A^t * A have the +* same trace. +* + ENTRAT = ZERO + DO 1114 p = N+1, N+M + BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * DLOG(BIG1) + 1114 CONTINUE + ENTRAT = - ENTRAT / DLOG(DBLE(M)) +* +* Analyze the entropies and decide A or A^t. Smaller entropy +* usually means better input for the algorithm. +* + TRANSP = ( ENTRAT .LT. ENTRA ) +* +* If A^t is better than A, transpose A. +* + IF ( TRANSP ) THEN +* In an optimal implementation, this trivial transpose +* should be replaced with faster transpose. + DO 1115 p = 1, N - 1 + DO 1116 q = p + 1, N + TEMP1 = A(q,p) + A(q,p) = A(p,q) + A(p,q) = TEMP1 + 1116 CONTINUE + 1115 CONTINUE + DO 1117 p = 1, N + WORK(M+N+p) = SVA(p) + SVA(p) = WORK(N+p) + 1117 CONTINUE + TEMP1 = AAPP + AAPP = AATMAX + AATMAX = TEMP1 + TEMP1 = AAQQ + AAQQ = AATMIN + AATMIN = TEMP1 + KILL = LSVEC + LSVEC = RSVEC + RSVEC = KILL +* + ROWPIV = .TRUE. + END IF +* + END IF +* END IF L2TRAN +* +* Scale the matrix so that its maximal singular value remains less +* than DSQRT(BIG) -- the matrix is scaled so that its maximal column +* has Euclidean norm equal to DSQRT(BIG/N). The only reason to keep +* DSQRT(BIG) instead of BIG is the fact that DGEJSV uses LAPACK and +* BLAS routines that, in some implementations, are not capable of +* working in the full interval [SFMIN,BIG] and that they may provoke +* overflows in the intermediate results. If the singular values spread +* from SFMIN to BIG, then DGESVJ will compute them. So, in that case, +* one should use DGESVJ instead of DGEJSV. +* + BIG1 = DSQRT( BIG ) + TEMP1 = DSQRT( BIG / DBLE(N) ) +* + CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) + IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN + AAQQ = ( AAQQ / AAPP ) * TEMP1 + ELSE + AAQQ = ( AAQQ * TEMP1 ) / AAPP + END IF + TEMP1 = TEMP1 * SCALEM + CALL DLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) +* +* To undo scaling at the end of this procedure, multiply the +* computed singular values with USCAL2 / USCAL1. +* + USCAL1 = TEMP1 + USCAL2 = AAPP +* + IF ( L2KILL ) THEN +* L2KILL enforces computation of nonzero singular values in +* the restricted range of condition number of the initial A, +* sigma_max(A) / sigma_min(A) approx. DSQRT(BIG)/DSQRT(SFMIN). + XSC = DSQRT( SFMIN ) + ELSE + XSC = SMALL +* +* Now, if the condition number of A is too big, +* sigma_max(A) / sigma_min(A) .GT. DSQRT(BIG/N) * EPSLN / SFMIN, +* as a precaution measure, the full SVD is computed using DGESVJ +* with accumulated Jacobi rotations. This provides numerically +* more robust computation, at the cost of slightly increased run +* time. Depending on the concrete implementation of BLAS and LAPACK +* (i.e. how they behave in presence of extreme ill-conditioning) the +* implementor may decide to remove this switch. + IF ( ( AAQQ.LT.DSQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN + JRACC = .TRUE. + END IF +* + END IF + IF ( AAQQ .LT. XSC ) THEN + DO 700 p = 1, N + IF ( SVA(p) .LT. XSC ) THEN + CALL DLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA ) + SVA(p) = ZERO + END IF + 700 CONTINUE + END IF +* +* Preconditioning using QR factorization with pivoting +* + IF ( ROWPIV ) THEN +* Optional row permutation (Bjoerck row pivoting): +* A result by Cox and Higham shows that the Bjoerck's +* row pivoting combined with standard column pivoting +* has similar effect as Powell-Reid complete pivoting. +* The ell-infinity norms of A are made nonincreasing. + DO 1952 p = 1, M - 1 + q = IDAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1 + IWORK(2*N+p) = q + IF ( p .NE. q ) THEN + TEMP1 = WORK(M+N+p) + WORK(M+N+p) = WORK(M+N+q) + WORK(M+N+q) = TEMP1 + END IF + 1952 CONTINUE + CALL DLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 ) + END IF +* +* End of the preparation phase (scaling, optional sorting and +* transposing, optional flushing of small columns). +* +* Preconditioning +* +* If the full SVD is needed, the right singular vectors are computed +* from a matrix equation, and for that we need theoretical analysis +* of the Businger-Golub pivoting. So we use DGEQP3 as the first RR QRF. +* In all other cases the first RR QRF can be chosen by other criteria +* (eg speed by replacing global with restricted window pivoting, such +* as in SGEQPX from TOMS # 782). Good results will be obtained using +* SGEQPX with properly (!) chosen numerical parameters. +* Any improvement of DGEQP3 improves overal performance of DGEJSV. +* +* A * P1 = Q1 * [ R1^t 0]^t: + DO 1963 p = 1, N +* .. all columns are free columns + IWORK(p) = 0 + 1963 CONTINUE + CALL DGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR ) +* +* The upper triangular matrix R1 from the first QRF is inspected for +* rank deficiency and possibilities for deflation, or possible +* ill-conditioning. Depending on the user specified flag L2RANK, +* the procedure explores possibilities to reduce the numerical +* rank by inspecting the computed upper triangular factor. If +* L2RANK or L2ABER are up, then DGEJSV will compute the SVD of +* A + dA, where ||dA|| <= f(M,N)*EPSLN. +* + NR = 1 + IF ( L2ABER ) THEN +* Standard absolute error bound suffices. All sigma_i with +* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an +* agressive enforcement of lower numerical rank by introducing a +* backward error of the order of N*EPSLN*||A||. + TEMP1 = DSQRT(DBLE(N))*EPSLN + DO 3001 p = 2, N + IF ( DABS(A(p,p)) .GE. (TEMP1*DABS(A(1,1))) ) THEN + NR = NR + 1 + ELSE + GO TO 3002 + END IF + 3001 CONTINUE + 3002 CONTINUE + ELSE IF ( L2RANK ) THEN +* .. similarly as above, only slightly more gentle (less agressive). +* Sudden drop on the diagonal of R1 is used as the criterion for +* close-to-rank-defficient. + TEMP1 = DSQRT(SFMIN) + DO 3401 p = 2, N + IF ( ( DABS(A(p,p)) .LT. (EPSLN*DABS(A(p-1,p-1))) ) .OR. + & ( DABS(A(p,p)) .LT. SMALL ) .OR. + & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 + NR = NR + 1 + 3401 CONTINUE + 3402 CONTINUE +* + ELSE +* The goal is high relative accuracy. However, if the matrix +* has high scaled condition number the relative accuracy is in +* general not feasible. Later on, a condition number estimator +* will be deployed to estimate the scaled condition number. +* Here we just remove the underflowed part of the triangular +* factor. This prevents the situation in which the code is +* working hard to get the accuracy not warranted by the data. + TEMP1 = DSQRT(SFMIN) + DO 3301 p = 2, N + IF ( ( DABS(A(p,p)) .LT. SMALL ) .OR. + & ( L2KILL .AND. (DABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 + NR = NR + 1 + 3301 CONTINUE + 3302 CONTINUE +* + END IF +* + ALMORT = .FALSE. + IF ( NR .EQ. N ) THEN + MAXPRJ = ONE + DO 3051 p = 2, N + TEMP1 = DABS(A(p,p)) / SVA(IWORK(p)) + MAXPRJ = DMIN1( MAXPRJ, TEMP1 ) + 3051 CONTINUE + IF ( MAXPRJ**2 .GE. ONE - DBLE(N)*EPSLN ) ALMORT = .TRUE. + END IF +* +* + SCONDA = - ONE + CONDR1 = - ONE + CONDR2 = - ONE +* + IF ( ERREST ) THEN + IF ( N .EQ. NR ) THEN + IF ( RSVEC ) THEN +* .. V is available as workspace + CALL DLACPY( 'U', N, N, A, LDA, V, LDV ) + DO 3053 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL DSCAL( p, ONE/TEMP1, V(1,p), 1 ) + 3053 CONTINUE + CALL DPOCON( 'U', N, V, LDV, ONE, TEMP1, + & WORK(N+1), IWORK(2*N+M+1), IERR ) + ELSE IF ( LSVEC ) THEN +* .. U is available as workspace + CALL DLACPY( 'U', N, N, A, LDA, U, LDU ) + DO 3054 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL DSCAL( p, ONE/TEMP1, U(1,p), 1 ) + 3054 CONTINUE + CALL DPOCON( 'U', N, U, LDU, ONE, TEMP1, + & WORK(N+1), IWORK(2*N+M+1), IERR ) + ELSE + CALL DLACPY( 'U', N, N, A, LDA, WORK(N+1), N ) + DO 3052 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL DSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 ) + 3052 CONTINUE +* .. the columns of R are scaled to have unit Euclidean lengths. + CALL DPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1, + & WORK(N+N*N+1), IWORK(2*N+M+1), IERR ) + END IF + SCONDA = ONE / DSQRT(TEMP1) +* SCONDA is an estimate of DSQRT(||(R^t * R)^(-1)||_1). +* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA + ELSE + SCONDA = - ONE + END IF + END IF +* + L2PERT = L2PERT .AND. ( DABS( A(1,1)/A(NR,NR) ) .GT. DSQRT(BIG1) ) +* If there is no violent scaling, artificial perturbation is not needed. +* +* Phase 3: +* + + IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN +* +* Singular Values only +* +* .. transpose A(1:NR,1:N) + DO 1946 p = 1, MIN0( N-1, NR ) + CALL DCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) + 1946 CONTINUE +* +* The following two DO-loops introduce small relative perturbation +* into the strict upper triangle of the lower triangular matrix. +* Small entries below the main diagonal are also changed. +* This modification is useful if the computing environment does not +* provide/allow FLUSH TO ZERO underflow, for it prevents many +* annoying denormalized numbers in case of strongly scaled matrices. +* The perturbation is structured so that it does not introduce any +* new perturbation of the singular values, and it does not destroy +* the job done by the preconditioner. +* The licence for this perturbation is in the variable L2PERT, which +* should be .FALSE. if FLUSH TO ZERO underflow is active. +* + IF ( .NOT. ALMORT ) THEN +* + IF ( L2PERT ) THEN +* XSC = DSQRT(SMALL) + XSC = EPSLN / DBLE(N) + DO 4947 q = 1, NR + TEMP1 = XSC*DABS(A(q,q)) + DO 4949 p = 1, N + IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) ) + & .OR. ( p .LT. q ) ) + & A(p,q) = DSIGN( TEMP1, A(p,q) ) + 4949 CONTINUE + 4947 CONTINUE + ELSE + CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA ) + END IF +* +* .. second preconditioning using the QR factorization +* + CALL DGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR ) +* +* .. and transpose upper to lower triangular + DO 1948 p = 1, NR - 1 + CALL DCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) + 1948 CONTINUE +* + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* +* .. again some perturbation (a "background noise") is added +* to drown denormals + IF ( L2PERT ) THEN +* XSC = DSQRT(SMALL) + XSC = EPSLN / DBLE(N) + DO 1947 q = 1, NR + TEMP1 = XSC*DABS(A(q,q)) + DO 1949 p = 1, NR + IF ( ( (p.GT.q) .AND. (DABS(A(p,q)).LE.TEMP1) ) + & .OR. ( p .LT. q ) ) + & A(p,q) = DSIGN( TEMP1, A(p,q) ) + 1949 CONTINUE + 1947 CONTINUE + ELSE + CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA ) + END IF +* +* .. and one-sided Jacobi rotations are started on a lower +* triangular matrix (plus perturbation which is ignored in +* the part which destroys triangular form (confusing?!)) +* + CALL DGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA, + & N, V, LDV, WORK, LWORK, INFO ) +* + SCALEM = WORK(1) + NUMRANK = IDNINT(WORK(2)) +* +* + ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN +* +* -> Singular Values and Right Singular Vectors <- +* + IF ( ALMORT ) THEN +* +* .. in this case NR equals N + DO 1998 p = 1, NR + CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + 1998 CONTINUE + CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) +* + CALL DGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA, + & WORK, LWORK, INFO ) + SCALEM = WORK(1) + NUMRANK = IDNINT(WORK(2)) + + ELSE +* +* .. two more QR factorizations ( one QRF is not enough, two require +* accumulated product of Jacobi rotations, three are perfect ) +* + CALL DLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA ) + CALL DGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR) + CALL DLACPY( 'Lower', NR, NR, A, LDA, V, LDV ) + CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) + CALL DGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) + DO 8998 p = 1, NR + CALL DCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) + 8998 CONTINUE + CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) +* + CALL DGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U, + & LDU, WORK(N+1), LWORK, INFO ) + SCALEM = WORK(N+1) + NUMRANK = IDNINT(WORK(N+2)) + IF ( NR .LT. N ) THEN + CALL DLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV ) + CALL DLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV ) + CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV ) + END IF +* + CALL DORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK, + & V, LDV, WORK(N+1), LWORK-N, IERR ) +* + END IF +* + DO 8991 p = 1, N + CALL DCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) + 8991 CONTINUE + CALL DLACPY( 'All', N, N, A, LDA, V, LDV ) +* + IF ( TRANSP ) THEN + CALL DLACPY( 'All', N, N, V, LDV, U, LDU ) + END IF +* + ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN +* +* -#- Singular Values and Left Singular Vectors -#- +* +* .. second preconditioning step to avoid need to accumulate +* Jacobi rotations in the Jacobi iterations. + DO 1965 p = 1, NR + CALL DCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) + 1965 CONTINUE + CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) +* + CALL DGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) +* + DO 1967 p = 1, NR - 1 + CALL DCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) + 1967 CONTINUE + CALL DLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) +* + CALL DGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, + & LDA, WORK(N+1), LWORK-N, INFO ) + SCALEM = WORK(N+1) + NUMRANK = IDNINT(WORK(N+2)) +* + IF ( NR .LT. M ) THEN + CALL DLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL DLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU ) + CALL DLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU ) + END IF + END IF +* + CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* + DO 1974 p = 1, N1 + XSC = ONE / DNRM2( M, U(1,p), 1 ) + CALL DSCAL( M, XSC, U(1,p), 1 ) + 1974 CONTINUE +* + IF ( TRANSP ) THEN + CALL DLACPY( 'All', N, N, U, LDU, V, LDV ) + END IF +* + ELSE +* +* -#- Full SVD -#- +* + IF ( .NOT. JRACC ) THEN +* + IF ( .NOT. ALMORT ) THEN +* +* Second Preconditioning Step (QRF [with pivoting]) +* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is +* equivalent to an LQF CALL. Since in many libraries the QRF +* seems to be better optimized than the LQF, we do explicit +* transpose and use the QRF. This is subject to changes in an +* optimized implementation of DGEJSV. +* + DO 1968 p = 1, NR + CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + 1968 CONTINUE +* +* .. the following two loops perturb small entries to avoid +* denormals in the second QR factorization, where they are +* as good as zeros. This is done to avoid painfully slow +* computation with denormals. The relative size of the perturbation +* is a parameter that can be changed by the implementer. +* This perturbation device will be obsolete on machines with +* properly implemented arithmetic. +* To switch it off, set L2PERT=.FALSE. To remove it from the +* code, remove the action under L2PERT=.TRUE., leave the ELSE part. +* The following two loops should be blocked and fused with the +* transposed copy above. +* + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL) + DO 2969 q = 1, NR + TEMP1 = XSC*DABS( V(q,q) ) + DO 2968 p = 1, N + IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 ) + & .OR. ( p .LT. q ) ) + & V(p,q) = DSIGN( TEMP1, V(p,q) ) + IF ( p. LT. q ) V(p,q) = - V(p,q) + 2968 CONTINUE + 2969 CONTINUE + ELSE + CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) + END IF +* +* Estimate the row scaled condition number of R1 +* (If R1 is rectangular, N > NR, then the condition number +* of the leading NR x NR submatrix is estimated.) +* + CALL DLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR ) + DO 3950 p = 1, NR + TEMP1 = DNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1) + CALL DSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1) + 3950 CONTINUE + CALL DPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1, + & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR) + CONDR1 = ONE / DSQRT(TEMP1) +* .. here need a second oppinion on the condition number +* .. then assume worst case scenario +* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N) +* more conservative <=> CONDR1 .LT. DSQRT(DBLE(N)) +* + COND_OK = DSQRT(DBLE(NR)) +*[TP] COND_OK is a tuning parameter. + + IF ( CONDR1 .LT. COND_OK ) THEN +* .. the second QRF without pivoting. Note: in an optimized +* implementation, this QRF should be implemented as the QRF +* of a lower triangular matrix. +* R1^t = Q2 * R2 + CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) +* + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL)/EPSLN + DO 3959 p = 2, NR + DO 3958 q = 1, p - 1 + TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q))) + IF ( DABS(V(q,p)) .LE. TEMP1 ) + & V(q,p) = DSIGN( TEMP1, V(q,p) ) + 3958 CONTINUE + 3959 CONTINUE + END IF +* + IF ( NR .NE. N ) +* .. save ... + & CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N ) +* +* .. this transposed copy should be better than naive + DO 1969 p = 1, NR - 1 + CALL DCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) + 1969 CONTINUE +* + CONDR2 = CONDR1 +* + ELSE +* +* .. ill-conditioned case: second QRF with pivoting +* Note that windowed pivoting would be equaly good +* numerically, and more run-time efficient. So, in +* an optimal implementation, the next call to DGEQP3 +* should be replaced with eg. CALL SGEQPX (ACM TOMS #782) +* with properly (carefully) chosen parameters. +* +* R1^t * P2 = Q2 * R2 + DO 3003 p = 1, NR + IWORK(N+p) = 0 + 3003 CONTINUE + CALL DGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1), + & WORK(2*N+1), LWORK-2*N, IERR ) +** CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), +** & LWORK-2*N, IERR ) + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL) + DO 3969 p = 2, NR + DO 3968 q = 1, p - 1 + TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q))) + IF ( DABS(V(q,p)) .LE. TEMP1 ) + & V(q,p) = DSIGN( TEMP1, V(q,p) ) + 3968 CONTINUE + 3969 CONTINUE + END IF +* + CALL DLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N ) +* + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL) + DO 8970 p = 2, NR + DO 8971 q = 1, p - 1 + TEMP1 = XSC * DMIN1(DABS(V(p,p)),DABS(V(q,q))) + V(p,q) = - DSIGN( TEMP1, V(q,p) ) + 8971 CONTINUE + 8970 CONTINUE + ELSE + CALL DLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV ) + END IF +* Now, compute R2 = L3 * Q3, the LQ factorization. + CALL DGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1), + & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) +* .. and estimate the condition number + CALL DLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR ) + DO 4950 p = 1, NR + TEMP1 = DNRM2( p, WORK(2*N+N*NR+NR+p), NR ) + CALL DSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR ) + 4950 CONTINUE + CALL DPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, + & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR ) + CONDR2 = ONE / DSQRT(TEMP1) +* + IF ( CONDR2 .GE. COND_OK ) THEN +* .. save the Householder vectors used for Q3 +* (this overwrittes the copy of R2, as it will not be +* needed in this branch, but it does not overwritte the +* Huseholder vectors of Q2.). + CALL DLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N ) +* .. and the rest of the information on Q3 is in +* WORK(2*N+N*NR+1:2*N+N*NR+N) + END IF +* + END IF +* + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL) + DO 4968 q = 2, NR + TEMP1 = XSC * V(q,q) + DO 4969 p = 1, q - 1 +* V(p,q) = - DSIGN( TEMP1, V(q,p) ) + V(p,q) = - DSIGN( TEMP1, V(p,q) ) + 4969 CONTINUE + 4968 CONTINUE + ELSE + CALL DLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV ) + END IF +* +* Second preconditioning finished; continue with Jacobi SVD +* The input matrix is lower trinagular. +* +* Recover the right singular vectors as solution of a well +* conditioned triangular matrix equation. +* + IF ( CONDR1 .LT. COND_OK ) THEN +* + CALL DGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, + & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO ) + SCALEM = WORK(2*N+N*NR+NR+1) + NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2)) + DO 3970 p = 1, NR + CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL DSCAL( NR, SVA(p), V(1,p), 1 ) + 3970 CONTINUE + +* .. pick the right matrix equation and solve it +* + IF ( NR. EQ. N ) THEN +* :)) .. best case, R1 is inverted. The solution of this matrix +* equation is Q2*V2 = the product of the Jacobi rotations +* used in DGESVJ, premultiplied with the orthogonal matrix +* from the second QR factorization. + CALL DTRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV ) + ELSE +* .. R1 is well conditioned, but non-square. Transpose(R2) +* is inverted to get the product of the Jacobi rotations +* used in DGESVJ. The Q-factor from the second QR +* factorization is then built in explicitly. + CALL DTRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1), + & N,V,LDV) + IF ( NR .LT. N ) THEN + CALL DLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV) + CALL DLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV) + CALL DLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV) + END IF + CALL DORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) + END IF +* + ELSE IF ( CONDR2 .LT. COND_OK ) THEN +* +* :) .. the input matrix A is very likely a relative of +* the Kahan matrix :) +* The matrix R2 is inverted. The solution of the matrix equation +* is Q3^T*V3 = the product of the Jacobi rotations (appplied to +* the lower triangular L3 from the LQ factorization of +* R2=L3*Q3), pre-multiplied with the transposed Q3. + CALL DGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, + & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO ) + SCALEM = WORK(2*N+N*NR+NR+1) + NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2)) + DO 3870 p = 1, NR + CALL DCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL DSCAL( NR, SVA(p), U(1,p), 1 ) + 3870 CONTINUE + CALL DTRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU) +* .. apply the permutation from the second QR factorization + DO 873 q = 1, NR + DO 872 p = 1, NR + WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 872 CONTINUE + DO 874 p = 1, NR + U(p,q) = WORK(2*N+N*NR+NR+p) + 874 CONTINUE + 873 CONTINUE + IF ( NR .LT. N ) THEN + CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) + CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) + CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) + END IF + CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) + ELSE +* Last line of defense. +* #:( This is a rather pathological case: no scaled condition +* improvement after two pivoted QR factorizations. Other +* possibility is that the rank revealing QR factorization +* or the condition estimator has failed, or the COND_OK +* is set very close to ONE (which is unnecessary). Normally, +* this branch should never be executed, but in rare cases of +* failure of the RRQR or condition estimator, the last line of +* defense ensures that DGEJSV completes the task. +* Compute the full SVD of L3 using DGESVJ with explicit +* accumulation of Jacobi rotations. + CALL DGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, + & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO ) + SCALEM = WORK(2*N+N*NR+NR+1) + NUMRANK = IDNINT(WORK(2*N+N*NR+NR+2)) + IF ( NR .LT. N ) THEN + CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) + CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) + CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) + END IF + CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* + CALL DORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N, + & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1), + & LWORK-2*N-N*NR-NR, IERR ) + DO 773 q = 1, NR + DO 772 p = 1, NR + WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 772 CONTINUE + DO 774 p = 1, NR + U(p,q) = WORK(2*N+N*NR+NR+p) + 774 CONTINUE + 773 CONTINUE +* + END IF +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = DSQRT(DBLE(N)) * EPSLN + DO 1972 q = 1, N + DO 972 p = 1, N + WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 972 CONTINUE + DO 973 p = 1, N + V(p,q) = WORK(2*N+N*NR+NR+p) + 973 CONTINUE + XSC = ONE / DNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL DSCAL( N, XSC, V(1,q), 1 ) + 1972 CONTINUE +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). + IF ( NR .LT. M ) THEN + CALL DLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL DLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU) + CALL DLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU) + END IF + END IF +* +* The Q matrix from the first QRF is built into the left singular +* matrix U. This applies to all cases. +* + CALL DORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) + +* The columns of U are normalized. The cost is O(M*N) flops. + TEMP1 = DSQRT(DBLE(M)) * EPSLN + DO 1973 p = 1, NR + XSC = ONE / DNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL DSCAL( M, XSC, U(1,p), 1 ) + 1973 CONTINUE +* +* If the initial QRF is computed with row pivoting, the left +* singular vectors must be adjusted. +* + IF ( ROWPIV ) + & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* + ELSE +* +* .. the initial matrix A has almost orthogonal columns and +* the second QRF is not needed +* + CALL DLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N ) + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL) + DO 5970 p = 2, N + TEMP1 = XSC * WORK( N + (p-1)*N + p ) + DO 5971 q = 1, p - 1 + WORK(N+(q-1)*N+p)=-DSIGN(TEMP1,WORK(N+(p-1)*N+q)) + 5971 CONTINUE + 5970 CONTINUE + ELSE + CALL DLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N ) + END IF +* + CALL DGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA, + & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO ) +* + SCALEM = WORK(N+N*N+1) + NUMRANK = IDNINT(WORK(N+N*N+2)) + DO 6970 p = 1, N + CALL DCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 ) + CALL DSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 ) + 6970 CONTINUE +* + CALL DTRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N, + & ONE, A, LDA, WORK(N+1), N ) + DO 6972 p = 1, N + CALL DCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV ) + 6972 CONTINUE + TEMP1 = DSQRT(DBLE(N))*EPSLN + DO 6971 p = 1, N + XSC = ONE / DNRM2( N, V(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL DSCAL( N, XSC, V(1,p), 1 ) + 6971 CONTINUE +* +* Assemble the left singular vector matrix U (M x N). +* + IF ( N .LT. M ) THEN + CALL DLASET( 'A', M-N, N, ZERO, ZERO, U(NR+1,1), LDU ) + IF ( N .LT. N1 ) THEN + CALL DLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU ) + CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(NR+1,N+1),LDU ) + END IF + END IF + CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) + TEMP1 = DSQRT(DBLE(M))*EPSLN + DO 6973 p = 1, N1 + XSC = ONE / DNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL DSCAL( M, XSC, U(1,p), 1 ) + 6973 CONTINUE +* + IF ( ROWPIV ) + & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* + END IF +* +* end of the >> almost orthogonal case << in the full SVD +* + ELSE +* +* This branch deploys a preconditioned Jacobi SVD with explicitly +* accumulated rotations. It is included as optional, mainly for +* experimental purposes. It does perfom well, and can also be used. +* In this implementation, this branch will be automatically activated +* if the condition number sigma_max(A) / sigma_min(A) is predicted +* to be greater than the overflow threshold. This is because the +* a posteriori computation of the singular vectors assumes robust +* implementation of BLAS and some LAPACK procedures, capable of working +* in presence of extreme values. Since that is not always the case, ... +* + DO 7968 p = 1, NR + CALL DCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + 7968 CONTINUE +* + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL/EPSLN) + DO 5969 q = 1, NR + TEMP1 = XSC*DABS( V(q,q) ) + DO 5968 p = 1, N + IF ( ( p .GT. q ) .AND. ( DABS(V(p,q)) .LE. TEMP1 ) + & .OR. ( p .LT. q ) ) + & V(p,q) = DSIGN( TEMP1, V(p,q) ) + IF ( p. LT. q ) V(p,q) = - V(p,q) + 5968 CONTINUE + 5969 CONTINUE + ELSE + CALL DLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) + END IF + + CALL DGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) + CALL DLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N ) +* + DO 7969 p = 1, NR + CALL DCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) + 7969 CONTINUE + + IF ( L2PERT ) THEN + XSC = DSQRT(SMALL/EPSLN) + DO 9970 q = 2, NR + DO 9971 p = 1, q - 1 + TEMP1 = XSC * DMIN1(DABS(U(p,p)),DABS(U(q,q))) + U(p,q) = - DSIGN( TEMP1, U(q,p) ) + 9971 CONTINUE + 9970 CONTINUE + ELSE + CALL DLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) + END IF + + CALL DGESVJ( 'G', 'U', 'V', NR, NR, U, LDU, SVA, + & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO ) + SCALEM = WORK(2*N+N*NR+1) + NUMRANK = IDNINT(WORK(2*N+N*NR+2)) + + IF ( NR .LT. N ) THEN + CALL DLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) + CALL DLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) + CALL DLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) + END IF + + CALL DORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = DSQRT(DBLE(N)) * EPSLN + DO 7972 q = 1, N + DO 8972 p = 1, N + WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 8972 CONTINUE + DO 8973 p = 1, N + V(p,q) = WORK(2*N+N*NR+NR+p) + 8973 CONTINUE + XSC = ONE / DNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL DSCAL( N, XSC, V(1,q), 1 ) + 7972 CONTINUE +* +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). +* + IF ( N .LT. M ) THEN + CALL DLASET( 'A', M-N, N, ZERO, ZERO, U(NR+1,1), LDU ) + IF ( N .LT. N1 ) THEN + CALL DLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU ) + CALL DLASET( 'A',M-N,N1-N, ZERO, ONE,U(NR+1,N+1),LDU ) + END IF + END IF +* + CALL DORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + & CALL DLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* +* + END IF + IF ( TRANSP ) THEN +* .. swap U and V because the procedure worked on A^t + DO 6974 p = 1, N + CALL DSWAP( N, U(1,p), 1, V(1,p), 1 ) + 6974 CONTINUE + END IF +* + END IF +* end of the full SVD +* +* Undo scaling, if necessary (and possible) +* + IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN + CALL DLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) + USCAL1 = ONE + USCAL2 = ONE + END IF +* + IF ( NR .LT. N ) THEN + DO 3004 p = NR+1, N + SVA(p) = ZERO + 3004 CONTINUE + END IF +* + WORK(1) = USCAL2 * SCALEM + WORK(2) = USCAL1 + IF ( ERREST ) WORK(3) = SCONDA + IF ( LSVEC .AND. RSVEC ) THEN + WORK(4) = CONDR1 + WORK(5) = CONDR2 + END IF + IF ( L2TRAN ) THEN + WORK(6) = ENTRA + WORK(7) = ENTRAT + END IF +* + IWORK(1) = NR + IWORK(2) = NUMRANK + IWORK(3) = WARNING +* + RETURN +* .. +* .. END OF DGEJSV +* .. + END +* diff --git a/SRC/dgelq2.f b/SRC/dgelq2.f index 386ea1b4..051a0984 100644 --- a/SRC/dgelq2.f +++ b/SRC/dgelq2.f @@ -1,6 +1,6 @@ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgelqf.f b/SRC/dgelqf.f index 063a38ba..fc8b79e0 100644 --- a/SRC/dgelqf.f +++ b/SRC/dgelqf.f @@ -1,6 +1,6 @@ SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgels.f b/SRC/dgels.f index 4fa1e229..163ce92b 100644 --- a/SRC/dgels.f +++ b/SRC/dgels.f @@ -1,7 +1,7 @@ SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgelsd.f b/SRC/dgelsd.f index 7b9a0a69..b6450834 100644 --- a/SRC/dgelsd.f +++ b/SRC/dgelsd.f @@ -1,7 +1,7 @@ SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgelss.f b/SRC/dgelss.f index f024e138..f38fe662 100644 --- a/SRC/dgelss.f +++ b/SRC/dgelss.f @@ -1,7 +1,7 @@ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgelsx.f b/SRC/dgelsx.f index a597cd47..3990f936 100644 --- a/SRC/dgelsx.f +++ b/SRC/dgelsx.f @@ -1,7 +1,7 @@ SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgelsy.f b/SRC/dgelsy.f index 4334650f..3a5c78ea 100644 --- a/SRC/dgelsy.f +++ b/SRC/dgelsy.f @@ -1,7 +1,7 @@ SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeql2.f b/SRC/dgeql2.f index 7b2d46b5..47682e84 100644 --- a/SRC/dgeql2.f +++ b/SRC/dgeql2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeqlf.f b/SRC/dgeqlf.f index ec293574..a99d356d 100644 --- a/SRC/dgeqlf.f +++ b/SRC/dgeqlf.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeqp3.f b/SRC/dgeqp3.f index d6bc537d..d8b64333 100644 --- a/SRC/dgeqp3.f +++ b/SRC/dgeqp3.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeqpf.f b/SRC/dgeqpf.f index 217499c3..88e3e8ac 100644 --- a/SRC/dgeqpf.f +++ b/SRC/dgeqpf.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * -* -- LAPACK deprecated driver routine (version 3.1) -- +* -- LAPACK deprecated driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeqr2.f b/SRC/dgeqr2.f index f3e012de..96843188 100644 --- a/SRC/dgeqr2.f +++ b/SRC/dgeqr2.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgeqrf.f b/SRC/dgeqrf.f index 1e940597..d7befb76 100644 --- a/SRC/dgeqrf.f +++ b/SRC/dgeqrf.f @@ -1,6 +1,6 @@ SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgerfs.f b/SRC/dgerfs.f index bada6e56..42ddc5d8 100644 --- a/SRC/dgerfs.f +++ b/SRC/dgerfs.f @@ -1,7 +1,7 @@ SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgerfsx.f b/SRC/dgerfsx.f new file mode 100644 index 00000000..0a6c2cb4 --- /dev/null +++ b/SRC/dgerfsx.f @@ -0,0 +1,605 @@ + SUBROUTINE DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ), WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DGERFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The original N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) +* The factors L and U from the factorization A = P*L*U +* as computed by DGETRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 100.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGECON, DLA_GERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, DLANGE, DLA_GERCOND + DOUBLE PRECISION DLAMCH, DLANGE, DLA_GERCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = DLANGE( NORM, N, N, A, LDA, WORK ) + CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + IF ( NOTRAN ) THEN + CALL DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), WORK(1), WORK(2*N+1), + $ WORK(1), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + ELSE + CALL DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), WORK(1), WORK(2*N+1), + $ WORK(1), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ -1, C, INFO, WORK, IWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ -1, R, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ 0, R, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, + $ IPIV, 1, X(1,J), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF +* + RETURN +* +* End of DGERFSX +* + END diff --git a/SRC/dgerq2.f b/SRC/dgerq2.f index 045eab90..3924dd97 100644 --- a/SRC/dgerq2.f +++ b/SRC/dgerq2.f @@ -1,6 +1,6 @@ SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgerqf.f b/SRC/dgerqf.f index 3dc22652..382e5a7e 100644 --- a/SRC/dgerqf.f +++ b/SRC/dgerqf.f @@ -1,6 +1,6 @@ SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgesc2.f b/SRC/dgesc2.f index 1b0331f5..9ef6253c 100644 --- a/SRC/dgesc2.f +++ b/SRC/dgesc2.f @@ -1,6 +1,6 @@ SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgesdd.f b/SRC/dgesdd.f index 7a202f1c..192c1430 100644 --- a/SRC/dgesdd.f +++ b/SRC/dgesdd.f @@ -1,7 +1,7 @@ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgesv.f b/SRC/dgesv.f index 220ef56f..2545da66 100644 --- a/SRC/dgesv.f +++ b/SRC/dgesv.f @@ -1,6 +1,6 @@ SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgesvd.f b/SRC/dgesvd.f index 0b62ca10..60344521 100644 --- a/SRC/dgesvd.f +++ b/SRC/dgesvd.f @@ -1,7 +1,7 @@ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgesvj.f b/SRC/dgesvj.f new file mode 100644 index 00000000..22538fe4 --- /dev/null +++ b/SRC/dgesvj.f @@ -0,0 +1,1352 @@ + SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, + & MV, V, LDV, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* -#- Scalar Arguments -#- +* + IMPLICIT NONE + INTEGER INFO, LDA, LDV, LWORK, M, MV, N + CHARACTER*1 JOBA, JOBU, JOBV +* +* -#- Array Arguments -#- +* + DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), WORK( LWORK ) +* .. +* +* Purpose +* ~~~~~~~ +* DGESVJ computes the singular value decomposition (SVD) of a real +* M-by-N matrix A, where M >= N. The SVD of A is written as +* [++] [xx] [x0] [xx] +* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx] +* [++] [xx] +* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal +* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements +* of SIGMA are the singular values of A. The columns of U and V are the +* left and the right singular vectors of A, respectively. +* +* Further Details +* ~~~~~~~~~~~~~~~ +* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane +* rotations. The rotations are implemented as fast scaled rotations of +* Anda and Park [1]. In the case of underflow of the Jacobi angle, a +* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses +* column interchanges of de Rijk [2]. The relative accuracy of the computed +* singular values and the accuracy of the computed singular vectors (in +* angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. +* The condition number that determines the accuracy in the full rank case +* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the +* spectral condition number. The best performance of this Jacobi SVD +* procedure is achieved if used in an accelerated version of Drmac and +* Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. +* Some tunning parameters (marked with [TP]) are available for the +* implementer. +* The computational range for the nonzero singular values is the machine +* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even +* denormalized singular values can be computed with the corresponding +* gradual loss of accurate digits. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* References +* ~~~~~~~~~~ +* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling. +* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174. +* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the +* singular value decomposition on a vector computer. +* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. +* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. +* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular +* value computation in floating point arithmetic. +* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222. +* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +* LAPACK Working note 169. +* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +* LAPACK Working note 170. +* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +* QSVD, (H,K)-SVD computations. +* Department of Mathematics, University of Zagreb, 2008. +* +* Bugs, Examples and Comments +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Please report all bugs and send interesting test examples and comments to +* drmac@math.hr. Thank you. +* +* Arguments +* ~~~~~~~~~ +* +* JOBA (input) CHARACTER* 1 +* Specifies the structure of A. +* = 'L': The input matrix A is lower triangular; +* = 'U': The input matrix A is upper triangular; +* = 'G': The input matrix A is general M-by-N matrix, M >= N. +* +* JOBU (input) CHARACTER*1 +* Specifies whether to compute the left singular vectors +* (columns of U): +* +* = 'U': The left singular vectors corresponding to the nonzero +* singular values are computed and returned in the leading +* columns of A. See more details in the description of A. +* The default numerical orthogonality threshold is set to +* approximately TOL=CTOL*EPS, CTOL=DSQRT(M), EPS=DLAMCH('E'). +* = 'C': Analogous to JOBU='U', except that user can control the +* level of numerical orthogonality of the computed left +* singular vectors. TOL can be set to TOL = CTOL*EPS, where +* CTOL is given on input in the array WORK. +* No CTOL smaller than ONE is allowed. CTOL greater +* than 1 / EPS is meaningless. The option 'C' +* can be used if M*EPS is satisfactory orthogonality +* of the computed left singular vectors, so CTOL=M could +* save few sweeps of Jacobi rotations. +* See the descriptions of A and WORK(1). +* = 'N': The matrix U is not computed. However, see the +* description of A. +* +* JOBV (input) CHARACTER*1 +* Specifies whether to compute the right singular vectors, that +* is, the matrix V: +* = 'V' : the matrix V is computed and returned in the array V +* = 'A' : the Jacobi rotations are applied to the MV-by-N +* array V. In other words, the right singular vector +* matrix V is not computed explicitly, instead it is +* applied to an MV-by-N matrix initially stored in the +* first MV rows of V. +* = 'N' : the matrix V is not computed and the array V is not +* referenced +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. +* M >= N >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* On exit, +* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C': +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If INFO .EQ. 0, +* ~~~~~~~~~~~~~~~ +* RANKA orthonormal columns of U are returned in the +* leading RANKA columns of the array A. Here RANKA <= N +* is the number of computed singular values of A that are +* above the underflow threshold DLAMCH('S'). The singular +* vectors corresponding to underflowed or zero singular +* values are not computed. The value of RANKA is returned +* in the array WORK as RANKA=NINT(WORK(2)). Also see the +* descriptions of SVA and WORK. The computed columns of U +* are mutually numerically orthogonal up to approximately +* TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'), +* see the description of JOBU. +* If INFO .GT. 0, +* ~~~~~~~~~~~~~~~ +* the procedure DGESVJ did not converge in the given number +* of iterations (sweeps). In that case, the computed +* columns of U may not be orthogonal up to TOL. The output +* U (stored in A), SIGMA (given by the computed singular +* values in SVA(1:N)) and V is still a decomposition of the +* input matrix A in the sense that the residual +* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small. +* +* If JOBU .EQ. 'N': +* ~~~~~~~~~~~~~~~~~ +* If INFO .EQ. 0 +* ~~~~~~~~~~~~~~ +* Note that the left singular vectors are 'for free' in the +* one-sided Jacobi SVD algorithm. However, if only the +* singular values are needed, the level of numerical +* orthogonality of U is not an issue and iterations are +* stopped when the columns of the iterated matrix are +* numerically orthogonal up to approximately M*EPS. Thus, +* on exit, A contains the columns of U scaled with the +* corresponding singular values. +* If INFO .GT. 0, +* ~~~~~~~~~~~~~~~ +* the procedure DGESVJ did not converge in the given number +* of iterations (sweeps). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* SVA (workspace/output) REAL array, dimension (N) +* On exit, +* If INFO .EQ. 0, +* ~~~~~~~~~~~~~~~ +* depending on the value SCALE = WORK(1), we have: +* If SCALE .EQ. ONE: +* ~~~~~~~~~~~~~~~~~~ +* SVA(1:N) contains the computed singular values of A. +* During the computation SVA contains the Euclidean column +* norms of the iterated matrices in the array A. +* If SCALE .NE. ONE: +* ~~~~~~~~~~~~~~~~~~ +* The singular values of A are SCALE*SVA(1:N), and this +* factored representation is due to the fact that some of the +* singular values of A might underflow or overflow. +* +* If INFO .GT. 0, +* ~~~~~~~~~~~~~~~ +* the procedure DGESVJ did not converge in the given number of +* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate. +* +* MV (input) INTEGER +* If JOBV .EQ. 'A', then the product of Jacobi rotations in DGESVJ +* is applied to the first MV rows of V. See the description of JOBV. +* +* V (input/output) REAL array, dimension (LDV,N) +* If JOBV = 'V', then V contains on exit the N-by-N matrix of +* the right singular vectors; +* If JOBV = 'A', then V contains the product of the computed right +* singular vector matrix and the initial matrix in +* the array V. +* If JOBV = 'N', then V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV .GE. 1. +* If JOBV .EQ. 'V', then LDV .GE. max(1,N). +* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) . +* +* WORK (input/workspace/output) REAL array, dimension max(4,M+N). +* On entry, +* If JOBU .EQ. 'C', +* ~~~~~~~~~~~~~~~~~ +* WORK(1) = CTOL, where CTOL defines the threshold for convergence. +* The process stops if all columns of A are mutually +* orthogonal up to CTOL*EPS, EPS=DLAMCH('E'). +* It is required that CTOL >= ONE, i.e. it is not +* allowed to force the routine to obtain orthogonality +* below EPSILON. +* On exit, +* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N) +* are the computed singular vcalues of A. +* (See description of SVA().) +* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero +* singular values. +* WORK(3) = NINT(WORK(3)) is the number of the computed singular +* values that are larger than the underflow threshold. +* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi +* rotations needed for numerical convergence. +* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep. +* This is useful information in cases when DGESVJ did +* not converge, as it can be used to estimate whether +* the output is stil useful and for post festum analysis. +* WORK(6) = the largest absolute value over all sines of the +* Jacobi rotation angles in the last sweep. It can be +* useful for a post festum analysis. +* +* LWORK length of WORK, WORK >= MAX(6,M+N) +* +* INFO (output) INTEGER +* = 0 : successful exit. +* < 0 : if INFO = -i, then the i-th argument had an illegal value +* > 0 : DGESVJ did not converge in the maximal allowed number (30) +* of sweeps. The output may still be useful. See the +* description of WORK. +* +* Local Parameters +* + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) + INTEGER NSWEEP + PARAMETER ( NSWEEP = 30 ) +* +* Local Scalars +* + DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, + & BIG, BIGTHETA, CS, CTOL, EPSILON, LARGE, + & MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, + & SCALE, SFMIN, SMALL, SN, T, TEMP1, + & THETA, THSIGN, TOL + INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, + & IJBLSK, ir1, ISWROT, jbc, jgl, KBL, + & LKAHEAD, MVL, N2, N34, N4, NBL, + & NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND + LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK, + & RSVEC, UCTOL, UPPER +* +* Local Arrays +* + DOUBLE PRECISION FASTR(5) +* +* Intrinsic Functions +* + INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT +* +* External Functions +* .. from BLAS + DOUBLE PRECISION DDOT, DNRM2 + EXTERNAL DDOT, DNRM2 + INTEGER IDAMAX + EXTERNAL IDAMAX +* .. from LAPACK + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH + LOGICAL LSAME + EXTERNAL LSAME +* +* External Subroutines +* .. from BLAS + EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP +* .. from LAPACK + EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA +* + EXTERNAL DGSVJ0, DGSVJ1 +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) + UCTOL = LSAME( JOBU, 'C' ) + RSVEC = LSAME( JOBV, 'V' ) + APPLV = LSAME( JOBV, 'A' ) + UPPER = LSAME( JOBA, 'U' ) + LOWER = LSAME( JOBA, 'L' ) +* + IF ( .NOT.( UPPER .OR. LOWER .OR. LSAME(JOBA,'G') ) ) THEN + INFO = - 1 + ELSE IF ( .NOT.( LSVEC .OR. UCTOL .OR. LSAME(JOBU,'N') ) ) THEN + INFO = - 2 + ELSE IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N') ) ) THEN + INFO = - 3 + ELSE IF ( M .LT. 0 ) THEN + INFO = - 4 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN + INFO = - 5 + ELSE IF ( LDA .LT. M ) THEN + INFO = - 7 + ELSE IF ( MV .LT. 0 ) THEN + INFO = - 9 + ELSE IF ( ( RSVEC .AND. (LDV .LT. N ) ) .OR. + & ( APPLV .AND. (LDV .LT. MV) ) ) THEN + INFO = -11 + ELSE IF ( UCTOL .AND. (WORK(1) .LE. ONE) ) THEN + INFO = - 12 + ELSE IF ( LWORK .LT. MAX0( M + N , 6 ) ) THEN + INFO = - 13 + ELSE + INFO = 0 + END IF +* +* #:( + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF +* +* #:) Quick return for void matrix +* + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN +* +* Set numerical parameters +* The stopping criterion for Jacobi rotations is +* +* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS +* +* where EPS is the round-off and CTOL is defined as follows: +* + IF ( UCTOL ) THEN +* ... user controlled + CTOL = WORK(1) + ELSE +* ... default + IF ( LSVEC .OR. RSVEC .OR. APPLV ) THEN + CTOL = DSQRT(DBLE(M)) + ELSE + CTOL = DBLE(M) + END IF + END IF +* ... and the machine dependent parameters are +*[!] (Make sure that DLAMCH() works properly on the target machine.) +* + EPSILON = DLAMCH('Epsilon') + ROOTEPS = DSQRT(EPSILON) + SFMIN = DLAMCH('SafeMinimum') + ROOTSFMIN = DSQRT(SFMIN) + SMALL = SFMIN / EPSILON + BIG = DLAMCH('Overflow') +* BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + LARGE = BIG / DSQRT(DBLE(M*N)) + BIGTHETA = ONE / ROOTEPS +* + TOL = CTOL * EPSILON + ROOTTOL = DSQRT(TOL) +* + IF ( DBLE(M)*EPSILON .GE. ONE ) THEN + INFO = - 5 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF +* +* Initialize the right singular vector matrix. +* + IF ( RSVEC ) THEN + MVL = N + CALL DLASET( 'A', MVL, N, ZERO, ONE, V, LDV ) + ELSE IF ( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV +* +* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N ) +*(!) If necessary, scale A to protect the largest singular value +* from overflow. It is possible that saving the largest singular +* value destroys the information about the small ones. +* This initial scaling is almost minimal in the sense that the +* goal is to make sure that no column norm overflows, and that +* DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries +* in A are detected, the procedure returns with INFO=-6. +* + SCALE = ONE / DSQRT(DBLE(M)*DBLE(N)) + NOSCALE = .TRUE. + GOSCALE = .TRUE. +* + IF ( LOWER ) THEN +* the input matrix is M-by-N lower triangular (trapezoidal) + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL DLASSQ( M-p+1, A(p,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 6 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF + AAQQ = DSQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCALE = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALE ) + IF ( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 1873 q = 1, p - 1 + SVA(q) = SVA(q)*SCALE + 1873 CONTINUE + END IF + END IF + 1874 CONTINUE + ELSE IF ( UPPER ) THEN +* the input matrix is M-by-N upper triangular (trapezoidal) + DO 2874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL DLASSQ( p, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 6 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF + AAQQ = DSQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCALE = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALE ) + IF ( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 2873 q = 1, p - 1 + SVA(q) = SVA(q)*SCALE + 2873 CONTINUE + END IF + END IF + 2874 CONTINUE + ELSE +* the input matrix is M-by-N general dense + DO 3874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 6 + CALL XERBLA( 'DGESVJ', -INFO ) + RETURN + END IF + AAQQ = DSQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCALE = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALE ) + IF ( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 3873 q = 1, p - 1 + SVA(q) = SVA(q)*SCALE + 3873 CONTINUE + END IF + END IF + 3874 CONTINUE + END IF +* + IF ( NOSCALE ) SCALE = ONE +* +* Move the smaller part of the spectrum from the underflow threshold +*(!) Start by determining the position of the nonzero entries of the +* array SVA() relative to ( SFMIN, BIG ). +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) ) + AAPP = DMAX1( AAPP, SVA(p) ) + 4781 CONTINUE +* +* #:) Quick return for zero matrix +* + IF ( AAPP .EQ. ZERO ) THEN + IF ( LSVEC ) CALL DLASET( 'G', M, N, ZERO, ONE, A, LDA ) + WORK(1) = ONE + WORK(2) = ZERO + WORK(3) = ZERO + WORK(4) = ZERO + WORK(5) = ZERO + WORK(6) = ZERO + RETURN + END IF +* +* #:) Quick return for one-column matrix +* + IF ( N .EQ. 1 ) THEN + IF ( LSVEC ) + & CALL DLASCL( 'G',0,0,SVA(1),SCALE,M,1,A(1,1),LDA,IERR ) + WORK(1) = ONE / SCALE + IF ( SVA(1) .GE. SFMIN ) THEN + WORK(2) = ONE + ELSE + WORK(2) = ZERO + END IF + WORK(3) = ZERO + WORK(4) = ZERO + WORK(5) = ZERO + WORK(6) = ZERO + RETURN + END IF +* +* Protect small singular values from underflow, and try to +* avoid underflows/overflows in computing Jacobi rotations. +* + SN = DSQRT( SFMIN / EPSILON ) + TEMP1 = DSQRT( BIG / DBLE(N) ) + IF ( (AAPP.LE.SN).OR.(AAQQ.GE.TEMP1) + & .OR.((SN.LE.AAQQ).AND.(AAPP.LE.TEMP1)) ) THEN + TEMP1 = DMIN1(BIG,TEMP1/AAPP) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.LE.TEMP1) ) THEN + TEMP1 = DMIN1( SN / AAQQ, BIG/(AAPP*DSQRT(DBLE(N))) ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF ( (AAQQ.GE.SN).AND.(AAPP.GE.TEMP1) ) THEN + TEMP1 = DMAX1( SN / AAQQ, TEMP1 / AAPP ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.GE.TEMP1) ) THEN + TEMP1 = DMIN1( SN / AAQQ, BIG / (DSQRT(DBLE(N))*AAPP)) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE + TEMP1 = ONE + END IF +* +* Scale, if necessary +* + IF ( TEMP1 .NE. ONE ) THEN + CALL DLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR ) + END IF + SCALE = TEMP1 * SCALE + IF ( SCALE .NE. ONE ) THEN + CALL DLASCL( JOBA, 0, 0, ONE, SCALE, M, N, A, LDA, IERR ) + SCALE = ONE / SCALE + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* + EMPTSW = ( N * ( N - 1 ) ) / 2 + NOTROT = 0 + FASTR(1) = ZERO +* +* A is represented in factored form A = A * diag(WORK), where diag(WORK) +* is initialized to identity. WORK is updated during fast scaled +* rotations. +* + DO 1868 q = 1, N + WORK(q) = ONE + 1868 CONTINUE +* +* + SWBAND = 3 +*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective +* if DGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm DGESVJ. For sweeps i=1:SWBAND the procedure +* works on pivots inside a band-like region around the diagonal. +* The boundaries are determined dynamically, based on the number of +* pivots above a threshold. +* + KBL = MIN0( 8, N ) +*[TP] KBL is a tuning parameter that defines the tile size in the +* tiling of the p-q loops of pivot pairs. In general, an optimal +* value of KBL depends on the matrix dimensions and on the +* parameters of the computer's memory. +* + NBL = N / KBL + IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1 +* + BLSKIP = KBL**2 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. +* + ROWSKIP = MIN0( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. +* + LKAHEAD = 1 +*[TP] LKAHEAD is a tuning parameter. +* +* Quasi block transformations, using the lower (upper) triangular +* structure of the input matrix. The quasi-block-cycling usually +* invokes cubic convergence. Big part of this cycle is done inside +* canonical subspaces of dimensions less than M. +* + IF ( (LOWER .OR. UPPER) .AND. (N .GT. MAX0(64, 4*KBL)) ) THEN +*[TP] The number of partition levels and the actual partition are +* tuning parameters. + N4 = N / 4 + N2 = N / 2 + N34 = 3 * N4 + IF ( APPLV ) THEN + q = 0 + ELSE + q = 1 + END IF +* + IF ( LOWER ) THEN +* +* This works very well on lower triangular matrices, in particular +* in the framework of the preconditioned Jacobi SVD (xGEJSV). +* The idea is simple: +* [+ 0 0 0] Note that Jacobi transformations of [0 0] +* [+ + 0 0] [0 0] +* [+ + x 0] actually work on [x 0] [x 0] +* [+ + x x] [x x]. [x x] +* + CALL DGSVJ0(JOBV,M-N34,N-N34,A(N34+1,N34+1),LDA,WORK(N34+1), + & SVA(N34+1),MVL,V(N34*q+1,N34+1),LDV,EPSILON,SFMIN,TOL,2, + & WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ0( JOBV,M-N2,N34-N2,A(N2+1,N2+1),LDA,WORK(N2+1), + & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,2, + & WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ1( JOBV,M-N2,N-N2,N4,A(N2+1,N2+1),LDA,WORK(N2+1), + & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1, + & WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ0( JOBV,M-N4,N2-N4,A(N4+1,N4+1),LDA,WORK(N4+1), + & SVA(N4+1),MVL,V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1, + & WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ0( JOBV,M,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ1( JOBV,M,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR ) +* +* + ELSE IF ( UPPER ) THEN +* +* + CALL DGSVJ0( JOBV,N4,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,2,WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ0(JOBV,N2,N4,A(1,N4+1),LDA,WORK(N4+1),SVA(N4+1),MVL, + & V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,WORK(N+1),LWORK-N, + & IERR ) +* + CALL DGSVJ1( JOBV,N2,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR ) +* + CALL DGSVJ0( JOBV,N2+N4,N4,A(1,N2+1),LDA,WORK(N2+1),SVA(N2+1),MVL, + & V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1, + & WORK(N+1),LWORK-N,IERR ) + + END IF +* + END IF +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + DO 1993 i = 1, NSWEEP +* +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* +* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs +* 1 <= p < q <= N. This is the first step toward a blocked implementation +* of the rotations. New implementation, based on block transformations, +* is under development. +* + DO 2000 ibr = 1, NBL +* + igl = ( ibr - 1 ) * KBL + 1 +* + DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr ) +* + igl = igl + ir1 * KBL +* + DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1) +* +* .. de Rijk's pivoting +* + q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + CALL DSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = WORK(p) + WORK(p) = WORK(q) + WORK(q) = TEMP1 + END IF +* + IF ( ir1 .EQ. 0 ) THEN +* +* Column norms are periodically updated by explicit +* norm computation. +* Caveat: +* Unfortunately, some BLAS implementations compute DNRM2(M,A(1,p),1) +* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to +* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and to +* underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). +* Hence, DNRM2 cannot be trusted, not even in the case when +* the true norm is far from the under(over)flow boundaries. +* If properly implemented DNRM2 is available, the IF-THEN-ELSE +* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)". +* + IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN + SVA(p) = DNRM2( M, A(1,p), 1 ) * WORK(p) + ELSE + TEMP1 = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, TEMP1, AAPP ) + SVA(p) = TEMP1 * DSQRT(AAPP) * WORK(p) + END IF + AAPP = SVA(p) + ELSE + AAPP = SVA(p) + END IF +* + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2002 q = p + 1, MIN0( igl + KBL - 1, N ) +* + AAQQ = SVA(q) +* + IF ( AAQQ .GT. ZERO ) THEN +* + AAPP0 = AAPP + IF ( AAQQ .GE. ONE ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, WORK(p), M, + & 1, WORK(N+1), LDA, IERR ) + AAPQ = DDOT( M, WORK(N+1),1, A(1,q),1 )*WORK(q) / AAQQ + END IF + ELSE + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, WORK(q), M, + & 1, WORK(N+1), LDA, IERR ) + AAPQ = DDOT( M, WORK(N+1),1, A(1,p),1 )*WORK(p) / AAPP + END IF + END IF +* + MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( DABS( AAPQ ) .GT. TOL ) THEN +* +* .. rotate +*[RTD] ROTATED = ROTATED + ONE +* + IF ( ir1 .EQ. 0 ) THEN + NOTROT = 0 + PSKIPPED = 0 + ISWROT = ISWROT + 1 + END IF +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ +* + IF ( DABS( THETA ) .GT. BIGTHETA ) THEN +* + T = HALF / THETA + FASTR(3) = T * WORK(p) / WORK(q) + FASTR(4) = - T * WORK(q) / WORK(p) + CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ ) + MXSINJ = DMAX1( MXSINJ, DABS(T) ) +* + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - DSIGN(ONE,AAPQ) + T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) ) + CS = DSQRT( ONE / ( ONE + T*T ) ) + SN = T * CS +* + MXSINJ = DMAX1( MXSINJ, DABS(SN) ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( DMAX1(ZERO, ONE-T*AQOAP*AAPQ) ) +* + APOAQ = WORK(p) / WORK(q) + AQOAP = WORK(q) / WORK(p) + IF ( WORK(p) .GE. ONE ) THEN + IF ( WORK(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) * CS + CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1) + END IF + END IF + ELSE + IF ( WORK(q) .GE. ONE ) THEN + CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + ELSE + IF ( WORK(p) .GE. WORK(q) ) THEN + CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL DAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE +* .. have to use modified Gram-Schmidt like transformation + CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL DLASCL( 'G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR ) + CALL DLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR ) + TEMP1 = -AAPQ * WORK(p) / WORK(q) + CALL DAXPY ( M, TEMP1, WORK(N+1), 1, A(1,q), 1 ) + CALL DLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR ) + SVA(q) = AAQQ*DSQRT( DMAX1( ZERO, ONE - AAPQ*AAPQ ) ) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q), SVA(p) +* recompute SVA(q), SVA(p). +* + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = DNRM2( M, A(1,q), 1 ) * WORK(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * DSQRT(AAQQ) * WORK(q) + END IF + END IF + IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * DSQRT(AAPP) * WORK(p) + END IF + SVA(p) = AAPP + END IF +* + ELSE +* A(:,p) and A(:,q) already numerically orthogonal + IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1 +*[RTD] SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + END IF + ELSE +* A(:,q) is zero column + IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + IF ( ir1 .EQ. 0 ) AAPP = - AAPP + NOTROT = 0 + GO TO 2103 + END IF +* + 2002 CONTINUE +* END q-LOOP +* + 2103 CONTINUE +* bailed out of q-loop +* + SVA(p) = AAPP +* + ELSE + SVA(p) = AAPP + IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) ) + & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p + END IF +* + 2001 CONTINUE +* end of the p-loop +* end of doing the block ( ibr, ibr ) + 1002 CONTINUE +* end of ir1-loop +* +* ... go to the off diagonal blocks +* + igl = ( ibr - 1 ) * KBL + 1 +* + DO 2010 jbc = ibr + 1, NBL +* + jgl = ( jbc - 1 ) * KBL + 1 +* +* doing the block at ( ibr, jbc ) +* + IJBLSK = 0 + DO 2100 p = igl, MIN0( igl + KBL - 1, N ) +* + AAPP = SVA(p) + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2200 q = jgl, MIN0( jgl + KBL - 1, N ) +* + AAQQ = SVA(q) + IF ( AAQQ .GT. ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* Safe Gram matrix computation +* + IF ( AAQQ .GE. ONE ) THEN + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ) .LE. AAPP + END IF + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, WORK(p), M, + & 1, WORK(N+1), LDA, IERR ) + AAPQ = DDOT( M, WORK(N+1), 1, A(1,q), 1 ) * + & WORK(q) / AAQQ + END IF + ELSE + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ .LE. ( AAPP / SMALL ) + END IF + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, WORK(q), M, 1, + & WORK(N+1), LDA, IERR ) + AAPQ = DDOT(M,WORK(N+1),1,A(1,p),1) * WORK(p) / AAPP + END IF + END IF +* + MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( DABS( AAPQ ) .GT. TOL ) THEN + NOTROT = 0 +*[RTD] ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ + IF ( AAQQ .GT. AAPP0 ) THETA = - THETA +* + IF ( DABS( THETA ) .GT. BIGTHETA ) THEN + T = HALF / THETA + FASTR(3) = T * WORK(p) / WORK(q) + FASTR(4) = -T * WORK(q) / WORK(p) + CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) ) + MXSINJ = DMAX1( MXSINJ, DABS(T) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - DSIGN(ONE,AAPQ) + IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN + T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) ) + CS = DSQRT( ONE / ( ONE + T*T ) ) + SN = T * CS + MXSINJ = DMAX1( MXSINJ, DABS(SN) ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ) +* + APOAQ = WORK(p) / WORK(q) + AQOAP = WORK(q) / WORK(p) + IF ( WORK(p) .GE. ONE ) THEN +* + IF ( WORK(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) * CS + CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + IF ( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 ) + CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 ) + END IF + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + END IF + ELSE + IF ( WORK(q) .GE. ONE ) THEN + CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + IF ( RSVEC ) THEN + CALL DAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 ) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 ) + END IF + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + ELSE + IF ( WORK(p) .GE. WORK(q) ) THEN + CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL DAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE + IF ( AAPP .GT. AAQQ ) THEN + CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR) + CALL DLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR) + TEMP1 = -AAPQ * WORK(p) / WORK(q) + CALL DAXPY(M,TEMP1,WORK(N+1),1,A(1,q),1) + CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR) + SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + ELSE + CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 ) + CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK(N+1),LDA,IERR) + CALL DLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR) + TEMP1 = -AAPQ * WORK(q) / WORK(p) + CALL DAXPY(M,TEMP1,WORK(N+1),1,A(1,p),1) + CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR) + SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = DNRM2( M, A(1,q), 1 ) * WORK(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * DSQRT(AAQQ) * WORK(q) + END IF + END IF + IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * DSQRT(AAPP) * WORK(p) + END IF + SVA(p) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 +*[RTD] SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN + SVA(p) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE +* + SVA(p) = AAPP +* + ELSE +* + IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1 + IF ( AAPP .LT. ZERO ) NOTROT = 0 +* + END IF +* + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN0( igl + KBL - 1, N ) + SVA(p) = DABS(SVA(p)) + 2012 CONTINUE +*** + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN + SVA(N) = DNRM2( M, A(1,N), 1 ) * WORK(N) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,N), 1, T, AAPP ) + SVA(N) = T * DSQRT(AAPP) * WORK(N) + END IF +* +* Additional steering devices +* + IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + & ( ISWROT .LE. N ) ) ) + & SWBAND = i +* + IF ( (i .GT. SWBAND+1) .AND. (MXAAPQ .LT. DSQRT(DBLE(N))*TOL) + & .AND. (DBLE(N)*MXAAPQ*MXSINJ .LT. TOL) ) THEN + GO TO 1994 + END IF +* + IF ( NOTROT .GE. EMPTSW ) GO TO 1994 +* + 1993 CONTINUE +* end i=1:NSWEEP loop +* +* #:( Reaching this point means that the procedure has not converged. + INFO = NSWEEP - 1 + GO TO 1995 +* + 1994 CONTINUE +* #:) Reaching this point means numerical convergence after the i-th +* sweep. +* + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the singular values and find how many are above +* the underflow threshold. +* + N2 = 0 + N4 = 0 + DO 5991 p = 1, N - 1 + q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = WORK(p) + WORK(p) = WORK(q) + WORK(q) = TEMP1 + CALL DSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + END IF + IF ( SVA(p) .NE. ZERO ) THEN + N4 = N4 + 1 + IF ( SVA(p)*SCALE .GT. SFMIN ) N2 = N2 + 1 + END IF + 5991 CONTINUE + IF ( SVA(N) .NE. ZERO ) THEN + N4 = N4 + 1 + IF ( SVA(N)*SCALE .GT. SFMIN ) N2 = N2 + 1 + END IF +* +* Normalize the left singular vectors. +* + IF ( LSVEC .OR. UCTOL ) THEN + DO 1998 p = 1, N2 + CALL DSCAL( M, WORK(p) / SVA(p), A(1,p), 1 ) + 1998 CONTINUE + END IF +* +* Scale the product of Jacobi rotations (assemble the fast rotations). +* + IF ( RSVEC ) THEN + IF ( APPLV ) THEN + DO 2398 p = 1, N + CALL DSCAL( MVL, WORK(p), V(1,p), 1 ) + 2398 CONTINUE + ELSE + DO 2399 p = 1, N + TEMP1 = ONE / DNRM2(MVL, V(1,p), 1 ) + CALL DSCAL( MVL, TEMP1, V(1,p), 1 ) + 2399 CONTINUE + END IF + END IF +* +* Undo scaling, if necessary (and possible). + IF ( ((SCALE.GT.ONE).AND.(SVA(1).LT.(BIG/SCALE))) + & .OR.((SCALE.LT.ONE).AND.(SVA(N2).GT.(SFMIN/SCALE))) ) THEN + DO 2400 p = 1, N + SVA(p) = SCALE*SVA(p) + 2400 CONTINUE + SCALE = ONE + END IF +* + WORK(1) = SCALE +* The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE +* then some of the singular values may overflow or underflow and +* the spectrum is given in this factored representation. +* + WORK(2) = DBLE(N4) +* N4 is the number of computed nonzero singular values of A. +* + WORK(3) = DBLE(N2) +* N2 is the number of singular values of A greater than SFMIN. +* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers +* that may carry some information. +* + WORK(4) = DBLE(i) +* i is the index of the last sweep before declaring convergence. +* + WORK(5) = MXAAPQ +* MXAAPQ is the largest absolute value of scaled pivots in the +* last sweep +* + WORK(6) = MXSINJ +* MXSINJ is the largest absolute value of the sines of Jacobi angles +* in the last sweep +* + RETURN +* .. +* .. END OF DGESVJ +* .. + END +* diff --git a/SRC/dgesvx.f b/SRC/dgesvx.f index 0645a20c..9ce0e4f7 100644 --- a/SRC/dgesvx.f +++ b/SRC/dgesvx.f @@ -2,7 +2,7 @@ $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgesvxx.f b/SRC/dgesvxx.f new file mode 100644 index 00000000..b188e93c --- /dev/null +++ b/SRC/dgesvxx.f @@ -0,0 +1,630 @@ + SUBROUTINE DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DGESVXX uses the LU factorization to compute the solution to a +* double precision system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. DGESVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* DGESVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* DGESVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what DGESVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose = Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is +* not 'N', then A must have been equilibrated by the scaling +* factors in R and/or C. A is not modified if FACT = 'F' or +* 'N', or if FACT = 'E' and EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the factors L and U from the factorization +* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then +* AF is the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by DGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In DGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, COLCND, RCMAX, RCMIN, ROWCND, + $ SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_RPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DGEEQUB, DGETRF, DGETRS, DLACPY, DLAQGE, + $ XERBLA, DLASCL2, DGERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DGERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DGEEQUB( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0D+0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0D+0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL DLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL DLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL DGETRF( N, N, AF, LDAF, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLA_RPVGRW( N, INFO, A, LDA, AF, LDAF ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = DLA_RPVGRW( N, N, A, LDA, AF, LDAF ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL DLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of DGESVXX + + END diff --git a/SRC/dgetc2.f b/SRC/dgetc2.f index 5842b213..b637da8b 100644 --- a/SRC/dgetc2.f +++ b/SRC/dgetc2.f @@ -1,6 +1,6 @@ SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgetf2.f b/SRC/dgetf2.f index 573b1408..51a1dc3f 100644 --- a/SRC/dgetf2.f +++ b/SRC/dgetf2.f @@ -1,6 +1,6 @@ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgetrf.f b/SRC/dgetrf.f index c5b9df33..2182de3e 100644 --- a/SRC/dgetrf.f +++ b/SRC/dgetrf.f @@ -1,6 +1,6 @@ SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgetri.f b/SRC/dgetri.f index 9f1c1182..fda42273 100644 --- a/SRC/dgetri.f +++ b/SRC/dgetri.f @@ -1,6 +1,6 @@ SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgetrs.f b/SRC/dgetrs.f index b7d17b0a..f58ed025 100644 --- a/SRC/dgetrs.f +++ b/SRC/dgetrs.f @@ -1,6 +1,6 @@ SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggbak.f b/SRC/dggbak.f index 8ed9fbd4..c39736e9 100644 --- a/SRC/dggbak.f +++ b/SRC/dggbak.f @@ -1,7 +1,7 @@ SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggbal.f b/SRC/dggbal.f index 2034880a..5390e483 100644 --- a/SRC/dggbal.f +++ b/SRC/dggbal.f @@ -1,7 +1,7 @@ SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgges.f b/SRC/dgges.f index d5b1455d..eda39705 100644 --- a/SRC/dgges.f +++ b/SRC/dgges.f @@ -2,7 +2,7 @@ $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, $ LDVSR, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggesx.f b/SRC/dggesx.f index f3548443..d5218d36 100644 --- a/SRC/dggesx.f +++ b/SRC/dggesx.f @@ -3,7 +3,7 @@ $ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, $ LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggev.f b/SRC/dggev.f index 4a204c33..3384ddb8 100644 --- a/SRC/dggev.f +++ b/SRC/dggev.f @@ -1,7 +1,7 @@ SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggevx.f b/SRC/dggevx.f index 0d2cc424..f5304322 100644 --- a/SRC/dggevx.f +++ b/SRC/dggevx.f @@ -3,7 +3,7 @@ $ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, $ RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggglm.f b/SRC/dggglm.f index d5e1d924..04a6a924 100644 --- a/SRC/dggglm.f +++ b/SRC/dggglm.f @@ -1,7 +1,7 @@ SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgghrd.f b/SRC/dgghrd.f index 6b8bbb08..e73a8723 100644 --- a/SRC/dgghrd.f +++ b/SRC/dgghrd.f @@ -1,7 +1,7 @@ SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgglse.f b/SRC/dgglse.f index 8a3444ea..d8c9e26d 100644 --- a/SRC/dgglse.f +++ b/SRC/dgglse.f @@ -1,7 +1,7 @@ SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggqrf.f b/SRC/dggqrf.f index 666dc885..d503c4fb 100644 --- a/SRC/dggqrf.f +++ b/SRC/dggqrf.f @@ -1,7 +1,7 @@ SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggrqf.f b/SRC/dggrqf.f index 497ee668..b83e1bec 100644 --- a/SRC/dggrqf.f +++ b/SRC/dggrqf.f @@ -1,7 +1,7 @@ SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggsvd.f b/SRC/dggsvd.f index 7e4df2b5..0cee70cf 100644 --- a/SRC/dggsvd.f +++ b/SRC/dggsvd.f @@ -2,7 +2,7 @@ $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dggsvp.f b/SRC/dggsvp.f index 21dfe443..007b92fb 100644 --- a/SRC/dggsvp.f +++ b/SRC/dggsvp.f @@ -2,7 +2,7 @@ $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -109,7 +109,7 @@ * The leading dimension of the array U. LDU >= max(1,M) if * JOBU = 'U'; LDU >= 1 otherwise. * -* V (output) DOUBLE PRECISION array, dimension (LDV,M) +* V (output) DOUBLE PRECISION array, dimension (LDV,P) * If JOBV = 'V', V contains the orthogonal matrix V. * If JOBV = 'N', V is not referenced. * diff --git a/SRC/dgsvj0.f b/SRC/dgsvj0.f new file mode 100644 index 00000000..39ed0542 --- /dev/null +++ b/SRC/dgsvj0.f @@ -0,0 +1,840 @@ + SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, + & SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* Scalar Arguments +* + IMPLICIT NONE + INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP + DOUBLE PRECISION EPS, SFMIN, TOL + CHARACTER*1 JOBV +* +* Array Arguments +* + DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), + & WORK( LWORK ) +* .. +* +* Purpose +* ~~~~~~~ +* DGSVJ0 is called from DGESVJ as a pre-processor and that is its main +* purpose. It applies Jacobi rotations in the same way as DGESVJ does, but +* it does not check convergence (stopping criterion). Few tuning +* parameters (marked by [TP]) are available for the implementer. +* +* Further details +* ~~~~~~~~~~~~~~~ +* DGSVJ0 is used just to enable SGESVJ to call a simplified version of +* itself to work on a submatrix of the original matrix. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* Bugs, Examples and Comments +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Please report all bugs and send interesting test examples and comments to +* drmac@math.hr. Thank you. +* +* Arguments +* ~~~~~~~~~ +* +* JOBV (input) CHARACTER*1 +* Specifies whether the output from this procedure is used +* to compute the matrix V: +* = 'V': the product of the Jacobi rotations is accumulated +* by postmulyiplying the N-by-N array V. +* (See the description of V.) +* = 'A': the product of the Jacobi rotations is accumulated +* by postmulyiplying the MV-by-N array V. +* (See the descriptions of MV and V.) +* = 'N': the Jacobi rotations are not accumulated. +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. +* M >= N >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, M-by-N matrix A, such that A*diag(D) represents +* the input matrix. +* On exit, +* A_onexit * D_onexit represents the input matrix A*diag(D) +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of D, TOL and NSWEEP.) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* D (input/workspace/output) REAL array, dimension (N) +* The array D accumulates the scaling factors from the fast scaled +* Jacobi rotations. +* On entry, A*diag(D) represents the input matrix. +* On exit, A_onexit*diag(D_onexit) represents the input matrix +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of A, TOL and NSWEEP.) +* +* SVA (input/workspace/output) REAL array, dimension (N) +* On entry, SVA contains the Euclidean norms of the columns of +* the matrix A*diag(D). +* On exit, SVA contains the Euclidean norms of the columns of +* the matrix onexit*diag(D_onexit). +* +* MV (input) INTEGER +* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then MV is not referenced. +* +* V (input/output) REAL array, dimension (LDV,N) +* If JOBV .EQ. 'V' then N rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV >= 1. +* If JOBV = 'V', LDV .GE. N. +* If JOBV = 'A', LDV .GE. MV. +* +* EPS (input) INTEGER +* EPS = SLAMCH('Epsilon') +* +* SFMIN (input) INTEGER +* SFMIN = SLAMCH('Safe Minimum') +* +* TOL (input) REAL +* TOL is the threshold for Jacobi rotations. For a pair +* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +* applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. +* +* NSWEEP (input) INTEGER +* NSWEEP is the number of sweeps of Jacobi rotations to be +* performed. +* +* WORK (workspace) REAL array, dimension LWORK. +* +* LWORK (input) INTEGER +* LWORK is the dimension of WORK. LWORK .GE. M. +* +* INFO (output) INTEGER +* = 0 : successful exit. +* < 0 : if INFO = -i, then the i-th argument had an illegal value +* +* Local Parameters + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) + +* Local Scalars + DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, + & BIG, BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, + & ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA, + & THSIGN + INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, ISWROT, + & jbc, jgl, KBL, LKAHEAD, MVL, NBL, NOTROT, p, PSKIPPED, + & q, ROWSKIP, SWBAND + LOGICAL APPLV, ROTOK, RSVEC + +* Local Arrays +* + DOUBLE PRECISION FASTR(5) +* +* Intrinsic Functions +* + INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT +* +* External Functions +* + DOUBLE PRECISION DDOT, DNRM2 + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 +* +* External Subroutines +* + EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP +* +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +* + APPLV = LSAME(JOBV,'A') + RSVEC = LSAME(JOBV,'V') + IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN + INFO = -1 + ELSE IF ( M .LT. 0 ) THEN + INFO = -2 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN + INFO = -3 + ELSE IF ( LDA .LT. M ) THEN + INFO = -5 + ELSE IF ( MV .LT. 0 ) THEN + INFO = -8 + ELSE IF ( LDV .LT. M ) THEN + INFO = -10 + ELSE IF ( TOL .LE. EPS ) THEN + INFO = -13 + ELSE IF ( NSWEEP .LT. 0 ) THEN + INFO = -14 + ELSE IF ( LWORK .LT. M ) THEN + INFO = -16 + ELSE + INFO = 0 + END IF +* +* #:( + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'DGSVJ0', -INFO ) + RETURN + END IF +* + IF ( RSVEC ) THEN + MVL = N + ELSE IF ( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV + + ROOTEPS = DSQRT(EPS) + ROOTSFMIN = DSQRT(SFMIN) + SMALL = SFMIN / EPS + BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + BIGTHETA = ONE / ROOTEPS + ROOTTOL = DSQRT(TOL) +* +* +* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- +* + EMPTSW = ( N * ( N - 1 ) ) / 2 + NOTROT = 0 + FASTR(1) = ZERO +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + + SWBAND = 0 +*[TP] SWBAND is a tuning parameter. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure +* ...... + + KBL = MIN0( 8, N ) +*[TP] KBL is a tuning parameter that defines the tile size in the +* tiling of the p-q loops of pivot pairs. In general, an optimal +* value of KBL depends on the matrix dimensions and on the +* parameters of the computer's memory. +* + NBL = N / KBL + IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1 + + BLSKIP = ( KBL**2 ) + 1 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. + + ROWSKIP = MIN0( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. + + LKAHEAD = 1 +*[TP] LKAHEAD is a tuning parameter. + SWBAND = 0 + PSKIPPED = 0 +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* + DO 2000 ibr = 1, NBL + + igl = ( ibr - 1 ) * KBL + 1 +* + DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr ) +* + igl = igl + ir1 * KBL +* + DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1) + +* .. de Rijk's pivoting + q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + CALL DSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = D(p) + D(p) = D(q) + D(q) = TEMP1 + END IF +* + IF ( ir1 .EQ. 0 ) THEN +* +* Column norms are periodically updated by explicit +* norm computation. +* Caveat: +* Some BLAS implementations compute DNRM2(M,A(1,p),1) +* as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in +* overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and +* undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). +* Hence, DNRM2 cannot be trusted, not even in the case when +* the true norm is far from the under(over)flow boundaries. +* If properly implemented DNRM2 is available, the IF-THEN-ELSE +* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)". +* + IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN + SVA(p) = DNRM2( M, A(1,p), 1 ) * D(p) + ELSE + TEMP1 = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, TEMP1, AAPP ) + SVA(p) = TEMP1 * DSQRT(AAPP) * D(p) + END IF + AAPP = SVA(p) + ELSE + AAPP = SVA(p) + END IF + +* + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2002 q = p + 1, MIN0( igl + KBL - 1, N ) +* + AAQQ = SVA(q) + + IF ( AAQQ .GT. ZERO ) THEN +* + AAPP0 = AAPP + IF ( AAQQ .GE. ONE ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,p), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, D(p), M, + & 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK,1, A(1,q),1 )*D(q) / AAQQ + END IF + ELSE + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,q), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, D(q), M, + & 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK,1, A(1,p),1 )*D(p) / AAPP + END IF + END IF +* + MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( DABS( AAPQ ) .GT. TOL ) THEN +* +* .. rotate +* ROTATED = ROTATED + ONE +* + IF ( ir1 .EQ. 0 ) THEN + NOTROT = 0 + PSKIPPED = 0 + ISWROT = ISWROT + 1 + END IF +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ +* + IF ( DABS( THETA ) .GT. BIGTHETA ) THEN +* + T = HALF / THETA + FASTR(3) = T * D(p) / D(q) + FASTR(4) = - T * D(q) / D(p) + CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ ) + MXSINJ = DMAX1( MXSINJ, DABS(T) ) +* + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - DSIGN(ONE,AAPQ) + T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) ) + CS = DSQRT( ONE / ( ONE + T*T ) ) + SN = T * CS +* + MXSINJ = DMAX1( MXSINJ, DABS(SN) ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( DMAX1(ZERO, ONE-T*AQOAP*AAPQ) ) +* + APOAQ = D(p) / D(q) + AQOAP = D(q) / D(p) + IF ( D(p) .GE. ONE ) THEN + IF ( D(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + D(p) = D(p) * CS + D(q) = D(q) * CS + CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1) + END IF + END IF + ELSE + IF ( D(q) .GE. ONE ) THEN + CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + ELSE + IF ( D(p) .GE. D(q) ) THEN + CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL DAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL DAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE +* .. have to use modified Gram-Schmidt like transformation + CALL DCOPY( M, A(1,p), 1, WORK, 1 ) + CALL DLASCL( 'G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR ) + CALL DLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR ) + TEMP1 = -AAPQ * D(p) / D(q) + CALL DAXPY ( M, TEMP1, WORK, 1, A(1,q), 1 ) + CALL DLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR ) + SVA(q) = AAQQ*DSQRT( DMAX1( ZERO, ONE - AAPQ*AAPQ ) ) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q), SVA(p) +* recompute SVA(q), SVA(p). + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = DNRM2( M, A(1,q), 1 ) * D(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * DSQRT(AAQQ) * D(q) + END IF + END IF + IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = DNRM2( M, A(1,p), 1 ) * D(p) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * DSQRT(AAPP) * D(p) + END IF + SVA(p) = AAPP + END IF +* + ELSE +* A(:,p) and A(:,q) already numerically orthogonal + IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF + ELSE +* A(:,q) is zero column + IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + IF ( ir1 .EQ. 0 ) AAPP = - AAPP + NOTROT = 0 + GO TO 2103 + END IF +* + 2002 CONTINUE +* END q-LOOP +* + 2103 CONTINUE +* bailed out of q-loop + + SVA(p) = AAPP + + ELSE + SVA(p) = AAPP + IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) ) + & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p + END IF +* + 2001 CONTINUE +* end of the p-loop +* end of doing the block ( ibr, ibr ) + 1002 CONTINUE +* end of ir1-loop +* +*........................................................ +* ... go to the off diagonal blocks +* + igl = ( ibr - 1 ) * KBL + 1 +* + DO 2010 jbc = ibr + 1, NBL +* + jgl = ( jbc - 1 ) * KBL + 1 +* +* doing the block at ( ibr, jbc ) +* + IJBLSK = 0 + DO 2100 p = igl, MIN0( igl + KBL - 1, N ) +* + AAPP = SVA(p) +* + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2200 q = jgl, MIN0( jgl + KBL - 1, N ) +* + AAQQ = SVA(q) +* + IF ( AAQQ .GT. ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* -#- Safe Gram matrix computation -#- +* + IF ( AAQQ .GE. ONE ) THEN + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ) .LE. AAPP + END IF + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,p), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, D(p), M, + & 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A(1,q), 1 ) * + & D(q) / AAQQ + END IF + ELSE + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ .LE. ( AAPP / SMALL ) + END IF + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,q), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, D(q), M, 1, + & WORK, LDA, IERR ) + AAPQ = DDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP + END IF + END IF +* + MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( DABS( AAPQ ) .GT. TOL ) THEN + NOTROT = 0 +* ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ + IF ( AAQQ .GT. AAPP0 ) THETA = - THETA +* + IF ( DABS( THETA ) .GT. BIGTHETA ) THEN + T = HALF / THETA + FASTR(3) = T * D(p) / D(q) + FASTR(4) = -T * D(q) / D(p) + CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) ) + MXSINJ = DMAX1( MXSINJ, DABS(T) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - DSIGN(ONE,AAPQ) + IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN + T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) ) + CS = DSQRT( ONE / ( ONE + T*T ) ) + SN = T * CS + MXSINJ = DMAX1( MXSINJ, DABS(SN) ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ) +* + APOAQ = D(p) / D(q) + AQOAP = D(q) / D(p) + IF ( D(p) .GE. ONE ) THEN +* + IF ( D(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + D(p) = D(p) * CS + D(q) = D(q) * CS + CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + IF ( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 ) + CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 ) + END IF + D(p) = D(p) * CS + D(q) = D(q) / CS + END IF + ELSE + IF ( D(q) .GE. ONE ) THEN + CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + IF ( RSVEC ) THEN + CALL DAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 ) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 ) + END IF + D(p) = D(p) / CS + D(q) = D(q) * CS + ELSE + IF ( D(p) .GE. D(q) ) THEN + CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL DAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE + IF ( AAPP .GT. AAQQ ) THEN + CALL DCOPY( M, A(1,p), 1, WORK, 1 ) + CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR) + CALL DLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR) + TEMP1 = -AAPQ * D(p) / D(q) + CALL DAXPY(M,TEMP1,WORK,1,A(1,q),1) + CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR) + SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + ELSE + CALL DCOPY( M, A(1,q), 1, WORK, 1 ) + CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR) + CALL DLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR) + TEMP1 = -AAPQ * D(q) / D(p) + CALL DAXPY(M,TEMP1,WORK,1,A(1,p),1) + CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR) + SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = DNRM2( M, A(1,q), 1 ) * D(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * DSQRT(AAQQ) * D(q) + END IF + END IF + IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = DNRM2( M, A(1,p), 1 ) * D(p) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * DSQRT(AAPP) * D(p) + END IF + SVA(p) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN + SVA(p) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE +* + SVA(p) = AAPP +* + ELSE + IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1 + IF ( AAPP .LT. ZERO ) NOTROT = 0 + END IF + + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN0( igl + KBL - 1, N ) + SVA(p) = DABS(SVA(p)) + 2012 CONTINUE +* + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN + SVA(N) = DNRM2( M, A(1,N), 1 ) * D(N) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,N), 1, T, AAPP ) + SVA(N) = T * DSQRT(AAPP) * D(N) + END IF +* +* Additional steering devices +* + IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + & ( ISWROT .LE. N ) ) ) + & SWBAND = i +* + IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.DBLE(N)*TOL).AND. + & (DBLE(N)*MXAAPQ*MXSINJ.LT.TOL))THEN + GO TO 1994 + END IF +* + IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + + 1993 CONTINUE +* end i=1:NSWEEP loop +* #:) Reaching this point means that the procedure has comleted the given +* number of iterations. + INFO = NSWEEP - 1 + GO TO 1995 + 1994 CONTINUE +* #:) Reaching this point means that during the i-th sweep all pivots were +* below the given tolerance, causing early exit. +* + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the vector D. + DO 5991 p = 1, N - 1 + q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = D(p) + D(p) = D(q) + D(q) = TEMP1 + CALL DSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + END IF + 5991 CONTINUE +* + RETURN +* .. +* .. END OF DGSVJ0 +* .. + END +* diff --git a/SRC/dgsvj1.f b/SRC/dgsvj1.f new file mode 100644 index 00000000..ddc7a6c0 --- /dev/null +++ b/SRC/dgsvj1.f @@ -0,0 +1,611 @@ + SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, + & EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* -#- Scalar Arguments -#- +* + IMPLICIT NONE + DOUBLE PRECISION EPS, SFMIN, TOL + INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP + CHARACTER*1 JOBV +* +* -#- Array Arguments -#- +* + DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), + & WORK( LWORK ) +* .. +* +* Purpose +* ~~~~~~~ +* DGSVJ1 is called from SGESVJ as a pre-processor and that is its main +* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but +* it targets only particular pivots and it does not check convergence +* (stopping criterion). Few tunning parameters (marked by [TP]) are +* available for the implementer. +* +* Further details +* ~~~~~~~~~~~~~~~ +* DGSVJ1 applies few sweeps of Jacobi rotations in the column space of +* the input M-by-N matrix A. The pivot pairs are taken from the (1,2) +* off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The +* block-entries (tiles) of the (1,2) off-diagonal block are marked by the +* [x]'s in the following scheme: +* +* | * * * [x] [x] [x]| +* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. +* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* +* In terms of the columns of A, the first N1 columns are rotated 'against' +* the remaining N-N1 columns, trying to increase the angle between the +* corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is +* tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. +* The number of sweeps is given in NSWEEP and the orthogonality threshold +* is given in TOL. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* Arguments +* ~~~~~~~~~ +* +* JOBV (input) CHARACTER*1 +* Specifies whether the output from this procedure is used +* to compute the matrix V: +* = 'V': the product of the Jacobi rotations is accumulated +* by postmulyiplying the N-by-N array V. +* (See the description of V.) +* = 'A': the product of the Jacobi rotations is accumulated +* by postmulyiplying the MV-by-N array V. +* (See the descriptions of MV and V.) +* = 'N': the Jacobi rotations are not accumulated. +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. +* M >= N >= 0. +* +* N1 (input) INTEGER +* N1 specifies the 2 x 2 block partition, the first N1 columns are +* rotated 'against' the remaining N-N1 columns of A. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, M-by-N matrix A, such that A*diag(D) represents +* the input matrix. +* On exit, +* A_onexit * D_onexit represents the input matrix A*diag(D) +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of N1, D, TOL and NSWEEP.) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* D (input/workspace/output) REAL array, dimension (N) +* The array D accumulates the scaling factors from the fast scaled +* Jacobi rotations. +* On entry, A*diag(D) represents the input matrix. +* On exit, A_onexit*diag(D_onexit) represents the input matrix +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of N1, A, TOL and NSWEEP.) +* +* SVA (input/workspace/output) REAL array, dimension (N) +* On entry, SVA contains the Euclidean norms of the columns of +* the matrix A*diag(D). +* On exit, SVA contains the Euclidean norms of the columns of +* the matrix onexit*diag(D_onexit). +* +* MV (input) INTEGER +* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then MV is not referenced. +* +* V (input/output) REAL array, dimension (LDV,N) +* If JOBV .EQ. 'V' then N rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV >= 1. +* If JOBV = 'V', LDV .GE. N. +* If JOBV = 'A', LDV .GE. MV. +* +* EPS (input) INTEGER +* EPS = SLAMCH('Epsilon') +* +* SFMIN (input) INTEGER +* SFMIN = SLAMCH('Safe Minimum') +* +* TOL (input) REAL +* TOL is the threshold for Jacobi rotations. For a pair +* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +* applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. +* +* NSWEEP (input) INTEGER +* NSWEEP is the number of sweeps of Jacobi rotations to be +* performed. +* +* WORK (workspace) REAL array, dimension LWORK. +* +* LWORK (input) INTEGER +* LWORK is the dimension of WORK. LWORK .GE. M. +* +* INFO (output) INTEGER +* = 0 : successful exit. +* < 0 : if INFO = -i, then the i-th argument had an illegal value +* +* -#- Local Parameters -#- +* + DOUBLE PRECISION ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 ) + +* -#- Local Scalars -#- +* + DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, + & BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, + & ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN + INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, ISWROT, jbc, + & jgl, KBL, MVL, NOTROT, nblc, nblr, p, PSKIPPED, q, + & ROWSKIP, SWBAND + LOGICAL APPLV, ROTOK, RSVEC +* +* Local Arrays +* + DOUBLE PRECISION FASTR(5) +* +* Intrinsic Functions +* + INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT +* +* External Functions +* + DOUBLE PRECISION DDOT, DNRM2 + INTEGER IDAMAX + LOGICAL LSAME + EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 +* +* External Subroutines +* + EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP +* +* + APPLV = LSAME(JOBV,'A') + RSVEC = LSAME(JOBV,'V') + IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN + INFO = -1 + ELSE IF ( M .LT. 0 ) THEN + INFO = -2 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN + INFO = -3 + ELSE IF ( N1 .LT. 0 ) THEN + INFO = -4 + ELSE IF ( LDA .LT. M ) THEN + INFO = -6 + ELSE IF ( MV .LT. 0 ) THEN + INFO = -9 + ELSE IF ( LDV .LT. M ) THEN + INFO = -11 + ELSE IF ( TOL .LE. EPS ) THEN + INFO = -14 + ELSE IF ( NSWEEP .LT. 0 ) THEN + INFO = -15 + ELSE IF ( LWORK .LT. M ) THEN + INFO = -17 + ELSE + INFO = 0 + END IF +* +* #:( + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'DGSVJ1', -INFO ) + RETURN + END IF +* + IF ( RSVEC ) THEN + MVL = N + ELSE IF ( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV + + ROOTEPS = DSQRT(EPS) + ROOTSFMIN = DSQRT(SFMIN) + SMALL = SFMIN / EPS + BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + LARGE = BIG / DSQRT(DBLE(M*N)) + BIGTHETA = ONE / ROOTEPS + ROOTTOL = DSQRT(TOL) +* +* -#- Initialize the right singular vector matrix -#- +* +* RSVEC = LSAME( JOBV, 'Y' ) +* + EMPTSW = N1 * ( N - N1 ) + NOTROT = 0 + FASTR(1) = ZERO +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + KBL = MIN0(8,N) + NBLR = N1 / KBL + IF ( ( NBLR * KBL ) .NE. N1 ) NBLR = NBLR + 1 + +* .. the tiling is nblr-by-nblc [tiles] + + NBLC = ( N - N1 ) / KBL + IF ( ( NBLC * KBL ) .NE. ( N - N1 ) ) NBLC = NBLC + 1 + BLSKIP = ( KBL**2 ) + 1 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. + + ROWSKIP = MIN0( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. + SWBAND = 0 +*[TP] SWBAND is a tuning parameter. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. +* +* +* | * * * [x] [x] [x]| +* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. +* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* + DO 2000 ibr = 1, NBLR + + igl = ( ibr - 1 ) * KBL + 1 +* +* +*........................................................ +* ... go to the off diagonal blocks + + igl = ( ibr - 1 ) * KBL + 1 + + DO 2010 jbc = 1, NBLC + + jgl = N1 + ( jbc - 1 ) * KBL + 1 + +* doing the block at ( ibr, jbc ) + + IJBLSK = 0 + DO 2100 p = igl, MIN0( igl + KBL - 1, N1 ) + + AAPP = SVA(p) + + IF ( AAPP .GT. ZERO ) THEN + + PSKIPPED = 0 + + DO 2200 q = jgl, MIN0( jgl + KBL - 1, N ) +* + AAQQ = SVA(q) + + IF ( AAQQ .GT. ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* -#- Safe Gram matrix computation -#- +* + IF ( AAQQ .GE. ONE ) THEN + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ) .LE. AAPP + END IF + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,p), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAPP, D(p), M, + & 1, WORK, LDA, IERR ) + AAPQ = DDOT( M, WORK, 1, A(1,q), 1 ) * + & D(q) / AAQQ + END IF + ELSE + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ .LE. ( AAPP / SMALL ) + END IF + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL DCOPY( M, A(1,q), 1, WORK, 1 ) + CALL DLASCL( 'G', 0, 0, AAQQ, D(q), M, 1, + & WORK, LDA, IERR ) + AAPQ = DDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP + END IF + END IF + + MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) ) + +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( DABS( AAPQ ) .GT. TOL ) THEN + NOTROT = 0 +* ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ + IF ( AAQQ .GT. AAPP0 ) THETA = - THETA + + IF ( DABS( THETA ) .GT. BIGTHETA ) THEN + T = HALF / THETA + FASTR(3) = T * D(p) / D(q) + FASTR(4) = -T * D(q) / D(p) + CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) ) + MXSINJ = DMAX1( MXSINJ, DABS(T) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - DSIGN(ONE,AAPQ) + IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN + T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) ) + CS = DSQRT( ONE / ( ONE + T*T ) ) + SN = T * CS + MXSINJ = DMAX1( MXSINJ, DABS(SN) ) + SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ) + + APOAQ = D(p) / D(q) + AQOAP = D(q) / D(p) + IF ( D(p) .GE. ONE ) THEN +* + IF ( D(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + D(p) = D(p) * CS + D(q) = D(q) * CS + CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + IF ( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 ) + CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 ) + END IF + D(p) = D(p) * CS + D(q) = D(q) / CS + END IF + ELSE + IF ( D(q) .GE. ONE ) THEN + CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + IF ( RSVEC ) THEN + CALL DAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 ) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 ) + END IF + D(p) = D(p) / CS + D(q) = D(q) * CS + ELSE + IF ( D(p) .GE. D(q) ) THEN + CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL DAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF + + ELSE + IF ( AAPP .GT. AAQQ ) THEN + CALL DCOPY( M, A(1,p), 1, WORK, 1 ) + CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR) + CALL DLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR) + TEMP1 = -AAPQ * D(p) / D(q) + CALL DAXPY(M,TEMP1,WORK,1,A(1,q),1) + CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR) + SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + ELSE + CALL DCOPY( M, A(1,q), 1, WORK, 1 ) + CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR) + CALL DLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR) + TEMP1 = -AAPQ * D(q) / D(p) + CALL DAXPY(M,TEMP1,WORK,1,A(1,p),1) + CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR) + SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = DMAX1( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = DNRM2( M, A(1,q), 1 ) * D(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL DLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * DSQRT(AAQQ) * D(q) + END IF + END IF + IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = DNRM2( M, A(1,p), 1 ) * D(p) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * DSQRT(AAPP) * D(p) + END IF + SVA(p) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 +* SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + +* IF ( NOTROT .GE. EMPTSW ) GO TO 2011 + IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN + SVA(p) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF + +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE + + SVA(p) = AAPP +* + ELSE + IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1 + IF ( AAPP .LT. ZERO ) NOTROT = 0 +*** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 + END IF + + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN0( igl + KBL - 1, N ) + SVA(p) = DABS(SVA(p)) + 2012 CONTINUE +*** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN + SVA(N) = DNRM2( M, A(1,N), 1 ) * D(N) + ELSE + T = ZERO + AAPP = ZERO + CALL DLASSQ( M, A(1,N), 1, T, AAPP ) + SVA(N) = T * DSQRT(AAPP) * D(N) + END IF +* +* Additional steering devices +* + IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + & ( ISWROT .LE. N ) ) ) + & SWBAND = i + + IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.DBLE(N)*TOL).AND. + & (DBLE(N)*MXAAPQ*MXSINJ.LT.TOL))THEN + GO TO 1994 + END IF + +* + IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + + 1993 CONTINUE +* end i=1:NSWEEP loop +* #:) Reaching this point means that the procedure has completed the given +* number of sweeps. + INFO = NSWEEP - 1 + GO TO 1995 + 1994 CONTINUE +* #:) Reaching this point means that during the i-th sweep all pivots were +* below the given threshold, causing early exit. + + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the vector D +* + DO 5991 p = 1, N - 1 + q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = D(p) + D(p) = D(q) + D(q) = TEMP1 + CALL DSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + END IF + 5991 CONTINUE +* + RETURN +* .. +* .. END OF DGSVJ1 +* .. + END +* diff --git a/SRC/dgtcon.f b/SRC/dgtcon.f index 793c7f24..3d0ebd18 100644 --- a/SRC/dgtcon.f +++ b/SRC/dgtcon.f @@ -1,7 +1,7 @@ SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgtrfs.f b/SRC/dgtrfs.f index 4150e294..58104d1a 100644 --- a/SRC/dgtrfs.f +++ b/SRC/dgtrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgtsv.f b/SRC/dgtsv.f index 79c4b71c..2d8eaa53 100644 --- a/SRC/dgtsv.f +++ b/SRC/dgtsv.f @@ -1,6 +1,6 @@ SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgtsvx.f b/SRC/dgtsvx.f index 76167b84..9e7ed224 100644 --- a/SRC/dgtsvx.f +++ b/SRC/dgtsvx.f @@ -2,7 +2,7 @@ $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgttrf.f b/SRC/dgttrf.f index b39527ef..d7c48396 100644 --- a/SRC/dgttrf.f +++ b/SRC/dgttrf.f @@ -1,6 +1,6 @@ SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgttrs.f b/SRC/dgttrs.f index 318d6a75..6daad190 100644 --- a/SRC/dgttrs.f +++ b/SRC/dgttrs.f @@ -1,7 +1,7 @@ SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dgtts2.f b/SRC/dgtts2.f index 4b123ab7..709c5bba 100644 --- a/SRC/dgtts2.f +++ b/SRC/dgtts2.f @@ -1,6 +1,6 @@ SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dhgeqz.f b/SRC/dhgeqz.f index de137dc1..58c0ff0b 100644 --- a/SRC/dhgeqz.f +++ b/SRC/dhgeqz.f @@ -2,7 +2,7 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dhsein.f b/SRC/dhsein.f index 9b4aa311..6b2767ac 100644 --- a/SRC/dhsein.f +++ b/SRC/dhsein.f @@ -2,7 +2,7 @@ $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dhseqr.f b/SRC/dhseqr.f index 5b307fa8..089af06c 100644 --- a/SRC/dhseqr.f +++ b/SRC/dhseqr.f @@ -1,8 +1,8 @@ SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK driver routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -107,9 +107,11 @@ * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. +* is sufficient and delivers very good and sometimes +* optimal performance. However, LWORK as large as 11*N +* may be required for optimal performance. A workspace +* query is recommended to determine the optimal workspace +* size. * * If LWORK = -1, then DHSEQR does a workspace query. * In this case, DHSEQR checks the input parameters and @@ -164,46 +166,50 @@ * to attain best performance in each particular * computational environment. * -* ISPEC=1: The DLAHQR vs DLAQR0 crossover point. +* ISPEC=12: The DLAHQR vs DLAQR0 crossover point. * Default: 75. (Must be at least 11.) * -* ISPEC=2: Recommended deflation window size. +* ISPEC=13: Recommended deflation window size. * This depends on ILO, IHI and NS. NS is the * number of simultaneous shifts returned -* by ILAENV(ISPEC=4). (See ISPEC=4 below.) +* by ILAENV(ISPEC=15). (See ISPEC=15 below.) * The default for (IHI-ILO+1).LE.500 is NS. * The default for (IHI-ILO+1).GT.500 is 3*NS/2. * -* ISPEC=3: Nibble crossover point. (See ILAENV for +* ISPEC=14: Nibble crossover point. (See IPARMQ for * details.) Default: 14% of deflation window * size. * -* ISPEC=4: Number of simultaneous shifts, NS, in -* a multi-shift QR iteration. +* ISPEC=15: Number of simultaneous shifts in a multishift +* QR iteration. * * If IHI-ILO+1 is ... * * greater than ...but less ... the * or equal to ... than default is * -* 1 30 NS - 2(+) -* 30 60 NS - 4(+) +* 1 30 NS = 2(+) +* 30 60 NS = 4(+) * 60 150 NS = 10(+) * 150 590 NS = ** * 590 3000 NS = 64 * 3000 6000 NS = 128 * 6000 infinity NS = 256 * -* (+) By default some or all matrices of this order +* (+) By default some or all matrices of this order * are passed to the implicit double shift routine -* DLAHQR and NS is ignored. See ISPEC=1 above -* and comments in IPARM for details. +* DLAHQR and this parameter is ignored. See +* ISPEC=12 above and comments in IPARMQ for +* details. * -* The asterisks (**) indicate an ad-hoc +* (**) The asterisks (**) indicate an ad-hoc * function of N increasing from 10 to 64. * -* ISPEC=5: Select structured matrix multiply. -* (See ILAENV for details.) Default: 3. +* ISPEC=16: Select structured matrix multiply. +* If the number of simultaneous shifts (specified +* by ISPEC=15) is less than 14, then the default +* for ISPEC=16 is 0. Otherwise the default for +* ISPEC=16 is 2. * * ================================================================ * Based on contributions by @@ -227,16 +233,15 @@ * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare DLAHQR failure. NL .GT. NTINY = 11 is -* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) INTEGER NL PARAMETER ( NL = 49 ) DOUBLE PRECISION ZERO, ONE diff --git a/SRC/disnan.f b/SRC/disnan.f index bcfd71c9..06c10845 100644 --- a/SRC/disnan.f +++ b/SRC/disnan.f @@ -1,7 +1,6 @@ - FUNCTION DISNAN( DIN ) - LOGICAL DISNAN + LOGICAL FUNCTION DISNAN(DIN) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -29,5 +28,6 @@ EXTERNAL DLAISNAN * .. * .. Executable Statements .. - DISNAN = DLAISNAN( DIN, DIN ) - END FUNCTION + DISNAN = DLAISNAN(DIN,DIN) + RETURN + END diff --git a/SRC/dla_gbamv.f b/SRC/dla_gbamv.f new file mode 100644 index 00000000..36a223a4 --- /dev/null +++ b/SRC/dla_gbamv.f @@ -0,0 +1,280 @@ + SUBROUTINE DLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, + $ INCX, BETA, Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* KL - INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU - INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* ALPHA - DOUBLE PRECISION +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( KL.LT.0 ) THEN + INFO = 4 + ELSE IF( KU.LT.0 ) THEN + INFO = 5 + ELSE IF( LDAB.LT.KL+KU+1 )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DLA_GBAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + KD = KU + 1 + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( AB( KD+I-J, J ) ) + ELSE + TEMP = ABS( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( AB( KD+I-J, J ) ) + ELSE + TEMP = ABS( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of DLA_GBAMV +* + END diff --git a/SRC/dla_gbrcond.f b/SRC/dla_gbrcond.f new file mode 100644 index 00000000..fd57665a --- /dev/null +++ b/SRC/dla_gbrcond.f @@ -0,0 +1,216 @@ + DOUBLE PRECISION FUNCTION DLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, + $ AFB, LDAFB, IPIV, CMODE, C, INFO, + $ WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), + $ C( * ) +* +* DLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a double precision workspace of size 5*N, and +* IWORK is an integer workspace of size N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J, KD + DOUBLE PRECISION AINVNM, TMP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_GBRCOND = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') + $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_GBRCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + DLA_GBRCOND = 1.0D+0 + RETURN + END IF +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + KD = KU + 1 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( KD+I-J, J ) * C( J ) ) + END IF + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( KD+I-J, J ) ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( KD+I-J, J ) / C( J ) ) + END IF + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( J, KD+I-J ) * C( J ) ) + END IF + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS(AB(J,KD+I-J)) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( J, KD+I-J ) / C( J ) ) + END IF + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF ( NOTRANS ) THEN + CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( NOTRANS ) THEN + CALL DGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK, N, INFO ) + ELSE + CALL DGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_GBRCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/dla_gbrfsx_extended.f b/SRC/dla_gbrfsx_extended.f new file mode 100644 index 00000000..e747c8a7 --- /dev/null +++ b/SRC/dla_gbrfsx_extended.f @@ -0,0 +1,303 @@ + SUBROUTINE DLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, + $ COLEQU, C, B, LDB, Y, LDY, + $ BERR_OUT, N_NORMS, ERRS_N, ERRS_C, + $ RES, AYB, DY, Y_TAIL, RCOND, + $ ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, + $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ Y( LDY, * ), RES(*), DY(*), Y_TAIL(*) + DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT(*), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGBTRS, DGBMV, BLAS_DGBMV_X, + $ BLAS_DGBMV2_X, DLA_GBAMV, DLA_WWADDW, DLAMCH, + $ CHLA_TRANSTYPE, DLA_LIN_BERR + DOUBLE PRECISION DLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + M = KL+KU+1 + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL DGBMV( TRANS, M, N, KL, KU, -1.0D+0, AB, LDAB, + $ Y( 1, J ), 1, 1.0D+0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_DGBMV_X( TRANS_TYPE, N, N, KL, KU, + $ -1.0D+0, AB, LDAB, Y( 1, J ), 1, 1.0D+0, RES, 1, + $ PREC_TYPE ) + ELSE + CALL BLAS_DGBMV2_X( TRANS_TYPE, N, N, KL, KU, -1.0D+0, + $ AB, LDAB, Y( 1, J ), Y_TAIL, 1, 1.0D+0, RES, 1, + $ PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, DY, N, + $ INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( .NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y(1,J), 1 ) + ELSE + CALL DLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DGBMV(TRANS, N, N, KL, KU, -1.0D+0, AB, LDAB, Y(1,J), + $ 1, 1.0D+0, RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_GBAMV( TRANS_TYPE, N, N, KL, KU, 1.0D+0, + $ AB, LDAB, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS +* + END DO +* + RETURN + END diff --git a/SRC/dla_gbrpvgrw.f b/SRC/dla_gbrpvgrw.f new file mode 100644 index 00000000..b233b683 --- /dev/null +++ b/SRC/dla_gbrpvgrw.f @@ -0,0 +1,46 @@ + DOUBLE PRECISION FUNCTION DLA_GBRPVGRW( N, KL, KU, NCOLS, AB, + $ LDAB, AFB, LDAFB ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, KL, KU, NCOLS, LDAB, LDAFB +* .. +* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION AMAX, UMAX, RPVGRW +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0D+0 +* + KD = KU + 1 + DO J = 1, NCOLS + AMAX = 0.0D+0 + UMAX = 0.0D+0 + DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) + AMAX = MAX( ABS( AB( KD+I-J, J)), AMAX ) + END DO + DO I = MAX( J-KU, 1 ), J + UMAX = MAX( ABS( AFB( KD+I-J, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + DLA_GBRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/dla_geamv.f b/SRC/dla_geamv.f new file mode 100644 index 00000000..6c042c03 --- /dev/null +++ b/SRC/dla_geamv.f @@ -0,0 +1,271 @@ + SUBROUTINE DLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, + $ Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N, TRANS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION +* Array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* Level 2 Blas routine. +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DLA_GEAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, LENX + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = 1, LENX + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF (.NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of DLA_GEAMV +* + END diff --git a/SRC/dla_gercond.f b/SRC/dla_gercond.f new file mode 100644 index 00000000..cb75a97e --- /dev/null +++ b/SRC/dla_gercond.f @@ -0,0 +1,189 @@ + DOUBLE PRECISION FUNCTION DLA_GERCOND ( TRANS, N, A, LDA, AF, + $ LDAF, IPIV, CMODE, C, INFO, WORK, + $ IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), + $ C( * ) +* +* DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a DOUBLE PRECISION workspace of size 3*N, and +* IWORK is an INTEGER workspace of size N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, TMP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_GERCOND = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') + $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_GERCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + DLA_GERCOND = 1.0D+0 + RETURN + END IF +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF (NOTRANS) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, N + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK(I) = WORK(I) * WORK(2*N+I) + END DO + + IF (NOTRANS) THEN + CALL DGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL DGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF (NOTRANS) THEN + CALL DGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL DGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_GERCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/dla_gerfsx_extended.f b/SRC/dla_gerfsx_extended.f new file mode 100644 index 00000000..c16d7b4a --- /dev/null +++ b/SRC/dla_gerfsx_extended.f @@ -0,0 +1,298 @@ + SUBROUTINE DLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, + $ LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, Y, LDY, BERR_OUT, N_NORMS, + $ ERRS_N, ERRS_C, RES, AYB, DY, + $ Y_TAIL, RCOND, ITHRESH, RTHRESH, + $ DZ_UB, IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DGETRS, DGEMV, BLAS_DGEMV_X, + $ BLAS_DGEMV2_X, DLA_GEAMV, DLA_WWADDW, DLAMCH, + $ CHLA_TRANSTYPE, DLA_LIN_BERR + DOUBLE PRECISION DLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS +* + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL DGEMV( TRANS, N, N, -1.0D+0, A, LDA, Y( 1, J ), 1, + $ 1.0D+0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_DGEMV_X( TRANS_TYPE, N, N, -1.0D+0, A, LDA, + $ Y( 1, J ), 1, 1.0D+0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_DGEMV2_X( TRANS_TYPE, N, N, -1.0D+0, A, LDA, + $ Y( 1, J ), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL +* + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y( 1, J ), 1 ) + ELSE + CALL DLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DGEMV( TRANS, N, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, + $ RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_GEAMV ( TRANS_TYPE, N, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/dla_lin_berr.f b/SRC/dla_lin_berr.f new file mode 100644 index 00000000..c8f1652a --- /dev/null +++ b/SRC/dla_lin_berr.f @@ -0,0 +1,60 @@ + SUBROUTINE DLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NZ, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) + DOUBLE PRECISION RES( N, NRHS ) +* +* DLA_LIN_BERR computes componentwise relative backward error from +* the formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* .. +* .. Local Scalars .. + DOUBLE PRECISION TMP + INTEGER I, J +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + EXTERNAL DLAMCH + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION SAFE1 +* .. +* .. Executable Statements .. +* +* Adding SAFE1 to the numerator guards against spuriously zero +* residuals. A similar safeguard is in the SLA_yyAMV routine used +* to compute AYB. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (NZ+1)*SAFE1 + + DO J = 1, NRHS + BERR(J) = 0.0D+0 + DO I = 1, N + IF (AYB(I,J) .NE. 0.0D+0) THEN + TMP = (SAFE1+ABS(RES(I,J)))/AYB(I,J) + BERR(J) = MAX( BERR(J), TMP ) + END IF +* +* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know +* the true residual also must be exactly 0.0. +* + END DO + END DO + END SUBROUTINE diff --git a/SRC/dla_porcond.f b/SRC/dla_porcond.f new file mode 100644 index 00000000..78a9d948 --- /dev/null +++ b/SRC/dla_porcond.f @@ -0,0 +1,202 @@ + DOUBLE PRECISION FUNCTION DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ CMODE, C, INFO, WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO, CMODE + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), + $ C( * ) +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) +* +* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a double precision workspace of size 3*N, and +* IWORK is an integer workspace of size N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, TMP + LOGICAL UP +* .. +* .. Array Arguments .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_PORCOND = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_PORCOND', -INFO ) + RETURN + END IF + + IF( N.EQ.0 ) THEN + DLA_PORCOND = 1.0D+0 + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( J ,I ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ENDIF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF (UP) THEN + CALL DPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) + ELSE + CALL DPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( UP ) THEN + CALL DPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) + ELSE + CALL DPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) + ENDIF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_PORCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/dla_porfsx_extended.f b/SRC/dla_porfsx_extended.f new file mode 100644 index 00000000..01e3010d --- /dev/null +++ b/SRC/dla_porfsx_extended.f @@ -0,0 +1,298 @@ + SUBROUTINE DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, COLEQU, C, B, LDB, Y, + $ LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, Y_PREC_STATE, BASE_RESIDUAL, + $ EXTRA_RESIDUAL, EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DPOTRS, DSYMV, BLAS_DSYMV_X, + $ BLAS_DSYMV2_X, DLA_SYAMV, DLA_WWADDW, + $ DLA_LIN_BERR + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, + $ 1.0D+0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_DSYMV_X( UPLO2, N, -1.0D+0, A, LDA, + $ Y( 1, J ), 1, 1.0D+0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_DSYMV2_X(UPLO2, N, -1.0D+0, A, LDA, + $ Y(1, J), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y(1,J), 1 ) + ELSE + CALL DLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, RES, + $ 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_SYAMV( UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/dla_porpvgrw.f b/SRC/dla_porpvgrw.f new file mode 100644 index 00000000..535b4e46 --- /dev/null +++ b/SRC/dla_porpvgrw.f @@ -0,0 +1,107 @@ + DOUBLE PRECISION FUNCTION DLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, + $ LDAF, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AMAX, UMAX, RPVGRW + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + EXTERNAL LSAME, DLASET + LOGICAL LSAME +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) +* +* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so +* we restrict the growth search to that minor and use only the first +* 2*NCOLS workspace entries. +* + RPVGRW = 1.0D+0 + DO I = 1, 2*NCOLS + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column. +* + IF ( UPPER ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( NCOLS+J ) = + $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( NCOLS+J ) = + $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of the factor in +* AF. No pivoting, so no permutations. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) + END DO + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + DLA_PORPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/dla_rpvgrw.f b/SRC/dla_rpvgrw.f new file mode 100644 index 00000000..791bd5a6 --- /dev/null +++ b/SRC/dla_rpvgrw.f @@ -0,0 +1,44 @@ + DOUBLE PRECISION FUNCTION DLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AMAX, UMAX, RPVGRW +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0D+0 +* + DO J = 1, NCOLS + AMAX = 0.0D+0 + UMAX = 0.0D+0 + DO I = 1, N + AMAX = MAX( ABS( A( I, J ) ), AMAX ) + END DO + DO I = 1, J + UMAX = MAX( ABS( AF( I, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + DLA_RPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/dla_syamv.f b/SRC/dla_syamv.f new file mode 100644 index 00000000..49c36152 --- /dev/null +++ b/SRC/dla_syamv.f @@ -0,0 +1,275 @@ + SUBROUTINE DLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N, UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DLA_SYAMV performs the matrix-vector operation +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* n by n symmetric matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* UPLO - INTEGER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = BLAS_UPPER Only the upper triangular part of A +* is to be referenced. +* +* UPLO = BLAS_LOWER Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION . +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION . +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCY ) ) +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* -- Modified for the absolute-value product, April 2006 +* Jason Riedy, UC Berkeley +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) ) THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of DLA_SYAMV +* + END diff --git a/SRC/dla_syrcond.f b/SRC/dla_syrcond.f new file mode 100644 index 00000000..751af1a6 --- /dev/null +++ b/SRC/dla_syrcond.f @@ -0,0 +1,205 @@ + DOUBLE PRECISION FUNCTION DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, + $ IPIV, CMODE, C, INFO, WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments + INTEGER IWORK( * ), IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) +* +* DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a double precision workspace of size 3*N, and +* IWORK is an integer workspace of size N. +* .. +* .. Local Scalars .. + CHARACTER NORMIN + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, SMLNUM, TMP + LOGICAL UP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, IDAMAX, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA, DSYTRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + DLA_SYRCOND = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLA_SYRCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + DLA_SYRCOND = 1.0D+0 + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( I, J) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ENDIF +* +* Estimate the norm of inv(op(A)). +* + SMLNUM = DLAMCH( 'Safe minimum' ) + AINVNM = 0.0D+0 + NORMIN = 'N' + + KASE = 0 + 10 CONTINUE + CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF ( UP ) THEN + call dsytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) + ELSE + call dsytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( UP ) THEN + call dsytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) + ELSE + call dsytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) + ENDIF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF +* + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ DLA_SYRCOND = ( 1.0D+0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/dla_syrfsx_extended.f b/SRC/dla_syrfsx_extended.f new file mode 100644 index 00000000..1a75ce8e --- /dev/null +++ b/SRC/dla_syrfsx_extended.f @@ -0,0 +1,298 @@ + SUBROUTINE DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, Y_PREC_STATE, BASE_RESIDUAL, + $ EXTRA_RESIDUAL, EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DCOPY, DSYTRS, DSYMV, BLAS_DSYMV_X, + $ BLAS_DSYMV2_X, DLA_SYAMV, DLA_WWADDW, + $ DLA_LIN_BERR + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N )*EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + IF (Y_PREC_STATE .EQ. BASE_RESIDUAL) THEN + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, + $ 1.0D+0, RES, 1 ) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_DSYMV_X( UPLO2, N, -1.0D+0, A, LDA, + $ Y( 1, J ), 1, 1.0D+0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_DSYMV2_X(UPLO2, N, -1.0D+0, A, LDA, + $ Y(1, J), Y_TAIL, 1, 1.0D+0, RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL DCOPY( N, RES, 1, DY, 1 ) + CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL DAXPY( N, 1.0D+0, DY, 1, Y(1,J), 1 ) + ELSE + CALL DLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). + CALL DCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL DSYMV( UPLO, N, -1.0D+0, A, LDA, Y(1,J), 1, 1.0D+0, RES, + $ 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL DLA_SYAMV( UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL DLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/dla_syrpvgrw.f b/SRC/dla_syrpvgrw.f new file mode 100644 index 00000000..90a19de4 --- /dev/null +++ b/SRC/dla_syrpvgrw.f @@ -0,0 +1,201 @@ + DOUBLE PRECISION FUNCTION DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + EXTERNAL LSAME, DLASET + LOGICAL LSAME +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF ( UPPER ) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0D+0 + DO I = 1, 2*N + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from dsytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = MAX( ABS( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = MAX( ABS( AF(I, K+1 ) ), WORK( K+1 ) ) + END DO + WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + DLA_SYRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/dla_wwaddw.f b/SRC/dla_wwaddw.f new file mode 100644 index 00000000..f9cba7e8 --- /dev/null +++ b/SRC/dla_wwaddw.f @@ -0,0 +1,53 @@ + SUBROUTINE DLA_WWADDW( N, X, Y, W ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ), Y( * ), W( * ) +* .. +* +* Purpose +* ======= +* +* DLA_WWADDW adds a vector W into a doubled-single vector (X, Y). +* +* This works for all extant IBM's hex and binary floating point +* arithmetics, but not for decimal. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The length of vectors X, Y, and W. +* +* X, Y (input/output) DOUBLE PRECISION array, length N +* The doubled-single accumulation vector. +* +* W (input) DOUBLE PRECISION array, length N +* The vector to be added. +* .. +* .. Local Scalars .. + DOUBLE PRECISION S + INTEGER I +* .. +* .. Executable Statements .. +* + DO 10 I = 1, N + S = X(I) + W(I) + S = (S + S) - S + Y(I) = ((X(I) - S) + W(I)) + Y(I) + X(I) = S + 10 CONTINUE + RETURN + END diff --git a/SRC/dlabad.f b/SRC/dlabad.f index 05ff5d44..ea18855c 100644 --- a/SRC/dlabad.f +++ b/SRC/dlabad.f @@ -1,6 +1,6 @@ SUBROUTINE DLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlabrd.f b/SRC/dlabrd.f index 196b130c..fb786e3f 100644 --- a/SRC/dlabrd.f +++ b/SRC/dlabrd.f @@ -1,7 +1,7 @@ SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlacn2.f b/SRC/dlacn2.f index 6705d256..8a9f2b41 100644 --- a/SRC/dlacn2.f +++ b/SRC/dlacn2.f @@ -1,6 +1,6 @@ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlacon.f b/SRC/dlacon.f index f113b03a..b7d7d438 100644 --- a/SRC/dlacon.f +++ b/SRC/dlacon.f @@ -1,6 +1,6 @@ SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlacpy.f b/SRC/dlacpy.f index d72603a5..75f979f0 100644 --- a/SRC/dlacpy.f +++ b/SRC/dlacpy.f @@ -1,6 +1,6 @@ SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dladiv.f b/SRC/dladiv.f index b6a74d1b..641d3428 100644 --- a/SRC/dladiv.f +++ b/SRC/dladiv.f @@ -1,6 +1,6 @@ SUBROUTINE DLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlae2.f b/SRC/dlae2.f index 8e81c608..98beeda1 100644 --- a/SRC/dlae2.f +++ b/SRC/dlae2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaebz.f b/SRC/dlaebz.f index dec0c362..c1e08dfc 100644 --- a/SRC/dlaebz.f +++ b/SRC/dlaebz.f @@ -2,7 +2,7 @@ $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, $ NAB, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed0.f b/SRC/dlaed0.f index cf54722e..6a237cfd 100644 --- a/SRC/dlaed0.f +++ b/SRC/dlaed0.f @@ -1,7 +1,7 @@ SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed1.f b/SRC/dlaed1.f index f9718bbe..88bc6af0 100644 --- a/SRC/dlaed1.f +++ b/SRC/dlaed1.f @@ -1,7 +1,7 @@ SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed2.f b/SRC/dlaed2.f index 1b0ecfe9..8926ad9a 100644 --- a/SRC/dlaed2.f +++ b/SRC/dlaed2.f @@ -1,7 +1,7 @@ SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed3.f b/SRC/dlaed3.f index b6846018..3f668f8c 100644 --- a/SRC/dlaed3.f +++ b/SRC/dlaed3.f @@ -1,7 +1,7 @@ SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, $ CTOT, W, S, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed4.f b/SRC/dlaed4.f index ef3238e2..a257e5e1 100644 --- a/SRC/dlaed4.f +++ b/SRC/dlaed4.f @@ -1,6 +1,6 @@ SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed5.f b/SRC/dlaed5.f index ca7e9056..26e352de 100644 --- a/SRC/dlaed5.f +++ b/SRC/dlaed5.f @@ -1,6 +1,6 @@ SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed6.f b/SRC/dlaed6.f index 58a48b1a..7262cada 100644 --- a/SRC/dlaed6.f +++ b/SRC/dlaed6.f @@ -1,6 +1,6 @@ SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * February 2007 * diff --git a/SRC/dlaed7.f b/SRC/dlaed7.f index 28b357f8..5e623ddb 100644 --- a/SRC/dlaed7.f +++ b/SRC/dlaed7.f @@ -3,7 +3,7 @@ $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed8.f b/SRC/dlaed8.f index 47076107..9e1389b7 100644 --- a/SRC/dlaed8.f +++ b/SRC/dlaed8.f @@ -2,7 +2,7 @@ $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaed9.f b/SRC/dlaed9.f index ca1c67a0..a7290233 100644 --- a/SRC/dlaed9.f +++ b/SRC/dlaed9.f @@ -1,7 +1,7 @@ SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, $ S, LDS, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaeda.f b/SRC/dlaeda.f index f5be4184..fdff90cd 100644 --- a/SRC/dlaeda.f +++ b/SRC/dlaeda.f @@ -1,7 +1,7 @@ SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaein.f b/SRC/dlaein.f index 9f9b5fa5..ba63809f 100644 --- a/SRC/dlaein.f +++ b/SRC/dlaein.f @@ -1,7 +1,7 @@ SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaev2.f b/SRC/dlaev2.f index 49402faa..c744adf0 100644 --- a/SRC/dlaev2.f +++ b/SRC/dlaev2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaexc.f b/SRC/dlaexc.f index 18e7d247..d4bb9dd9 100644 --- a/SRC/dlaexc.f +++ b/SRC/dlaexc.f @@ -1,7 +1,7 @@ SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlag2.f b/SRC/dlag2.f index e754203b..c2267a74 100644 --- a/SRC/dlag2.f +++ b/SRC/dlag2.f @@ -1,7 +1,7 @@ SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlag2s.f b/SRC/dlag2s.f index e879987e..db8c84cb 100644 --- a/SRC/dlag2s.f +++ b/SRC/dlag2s.f @@ -1,21 +1,16 @@ - SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO) + SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO ) * -* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) -- +* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* January 2007 +* August 2007 * * .. -* .. WARNING: PROTOTYPE .. -* This is an LAPACK PROTOTYPE routine which means that the -* interface of this routine is likely to be changed in the future -* based on community feedback. -* * .. Scalar Arguments .. - INTEGER INFO,LDA,LDSA,M,N + INTEGER INFO, LDA, LDSA, M, N * .. * .. Array Arguments .. - REAL SA(LDSA,*) - DOUBLE PRECISION A(LDA,*) + REAL SA( LDSA, * ) + DOUBLE PRECISION A( LDA, * ) * .. * * Purpose @@ -28,7 +23,7 @@ * DLAG2S checks that all the entries of A are between -RMAX and * RMAX. If not the convertion is aborted and a flag is raised. * -* This is a helper routine so there is no argument checking. +* This is an auxiliary routine so there is no argument checking. * * Arguments * ========= @@ -46,40 +41,42 @@ * The leading dimension of the array A. LDA >= max(1,M). * * SA (output) REAL array, dimension (LDSA,N) -* On exit, if INFO=0, the M-by-N coefficient matrix SA. +* On exit, if INFO=0, the M-by-N coefficient matrix SA; if +* INFO>0, the content of SA is unspecified. * * LDSA (input) INTEGER * The leading dimension of the array SA. LDSA >= max(1,M). * * INFO (output) INTEGER -* = 0: successful exit -* > 0: if INFO = k, the (i,j) entry of the matrix A has -* overflowed when moving from DOUBLE PRECISION to SINGLE -* k is given by k = (i-1)*LDA+j +* = 0: successful exit. +* = 1: an entry of the matrix A is greater than the SINGLE +* PRECISION overflow threshold, in this case, the content +* of SA in exit is unspecified. * * ========= * * .. Local Scalars .. - INTEGER I,J - DOUBLE PRECISION RMAX + INTEGER I, J + DOUBLE PRECISION RMAX * .. * .. External Functions .. - REAL SLAMCH - EXTERNAL SLAMCH + REAL SLAMCH + EXTERNAL SLAMCH * .. * .. Executable Statements .. * - RMAX = SLAMCH('O') - DO 20 J = 1,N - DO 30 I = 1,M - IF ((A(I,J).LT.-RMAX) .OR. (A(I,J).GT.RMAX)) THEN - INFO = (I-1)*LDA + J - GO TO 10 - END IF - SA(I,J) = A(I,J) - 30 CONTINUE + RMAX = SLAMCH( 'O' ) + DO 20 J = 1, N + DO 10 I = 1, M + IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) THEN + INFO = 1 + GO TO 30 + END IF + SA( I, J ) = A( I, J ) + 10 CONTINUE 20 CONTINUE - 10 CONTINUE + INFO = 0 + 30 CONTINUE RETURN * * End of DLAG2S diff --git a/SRC/dlags2.f b/SRC/dlags2.f index 837a58e9..a77482d7 100644 --- a/SRC/dlags2.f +++ b/SRC/dlags2.f @@ -1,7 +1,7 @@ SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlagtf.f b/SRC/dlagtf.f index e91357bf..ba3b2f1f 100644 --- a/SRC/dlagtf.f +++ b/SRC/dlagtf.f @@ -1,6 +1,6 @@ SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlagtm.f b/SRC/dlagtm.f index 1d13efc2..91724239 100644 --- a/SRC/dlagtm.f +++ b/SRC/dlagtm.f @@ -1,7 +1,7 @@ SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlagts.f b/SRC/dlagts.f index 2606e23a..398f6e32 100644 --- a/SRC/dlagts.f +++ b/SRC/dlagts.f @@ -1,6 +1,6 @@ SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlagv2.f b/SRC/dlagv2.f index 15bcb0b9..6f0e51b8 100644 --- a/SRC/dlagv2.f +++ b/SRC/dlagv2.f @@ -1,7 +1,7 @@ SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlahqr.f b/SRC/dlahqr.f index 449a3770..469133e3 100644 --- a/SRC/dlahqr.f +++ b/SRC/dlahqr.f @@ -1,8 +1,8 @@ SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -118,11 +118,10 @@ * * 12-04 Further modifications by * Ralph Byers, University of Kansas, USA -* -* This is a modified version of DLAHQR from LAPACK version 3.0. -* It is (1) more robust against overflow and underflow and -* (2) adopts the more conservative Ahues & Tisseur stopping -* criterion (LAWN 122, 1997). +* This is a modified version of DLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). * * ========================================================= * @@ -265,10 +264,20 @@ I2 = I END IF * - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN + IF( ITS.EQ.10 ) THEN +* +* Exceptional shift. +* + S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) + H11 = DAT1*S + H( L, L ) + H12 = DAT2*S + H21 = S + H22 = H11 + ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * + S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H11 = DAT1*S + H( I, I ) H12 = DAT2*S H21 = S @@ -373,7 +382,11 @@ IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN - H( K, K-1 ) = -H( K, K-1 ) +* ==== Use the following instead of +* . H( K, K-1 ) = -H( K, K-1 ) to +* . avoid a bug when v(2) and v(3) +* . underflow. ==== + H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) END IF V2 = V( 2 ) T2 = T1*V2 diff --git a/SRC/dlahr2.f b/SRC/dlahr2.f index 6af74977..d204394c 100644 --- a/SRC/dlahr2.f +++ b/SRC/dlahr2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlahrd.f b/SRC/dlahrd.f index a04133d1..a510f5f7 100644 --- a/SRC/dlahrd.f +++ b/SRC/dlahrd.f @@ -1,6 +1,6 @@ SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaic1.f b/SRC/dlaic1.f index 44baece1..97cafff5 100644 --- a/SRC/dlaic1.f +++ b/SRC/dlaic1.f @@ -1,6 +1,6 @@ SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaisnan.f b/SRC/dlaisnan.f index 6a6c7a91..40ed433b 100644 --- a/SRC/dlaisnan.f +++ b/SRC/dlaisnan.f @@ -1,12 +1,11 @@ - FUNCTION DLAISNAN( DIN1, DIN2 ) - LOGICAL DLAISNAN + LOGICAL FUNCTION DLAISNAN(DIN1,DIN2) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. - DOUBLE PRECISION DIN1, DIN2 + DOUBLE PRECISION DIN1,DIN2 * .. * * Purpose @@ -37,4 +36,5 @@ * * .. Executable Statements .. DLAISNAN = (DIN1.NE.DIN2) - END FUNCTION + RETURN + END diff --git a/SRC/dlaln2.f b/SRC/dlaln2.f index 7c99bdbe..991d59b8 100644 --- a/SRC/dlaln2.f +++ b/SRC/dlaln2.f @@ -1,7 +1,7 @@ SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlals0.f b/SRC/dlals0.f index ed810237..d3f0da17 100644 --- a/SRC/dlals0.f +++ b/SRC/dlals0.f @@ -2,7 +2,7 @@ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlalsa.f b/SRC/dlalsa.f index 418320ef..e2e85ed7 100644 --- a/SRC/dlalsa.f +++ b/SRC/dlalsa.f @@ -3,7 +3,7 @@ $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlalsd.f b/SRC/dlalsd.f index f6a0c8b9..48a9b142 100644 --- a/SRC/dlalsd.f +++ b/SRC/dlalsd.f @@ -1,7 +1,7 @@ SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlamrg.f b/SRC/dlamrg.f index db2bd4b3..ce026ff2 100644 --- a/SRC/dlamrg.f +++ b/SRC/dlamrg.f @@ -1,6 +1,6 @@ SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaneg.f b/SRC/dlaneg.f index fead657c..cb895a15 100644 --- a/SRC/dlaneg.f +++ b/SRC/dlaneg.f @@ -2,7 +2,7 @@ IMPLICIT NONE INTEGER DLANEG * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlangb.f b/SRC/dlangb.f index 2fea84de..a859c58b 100644 --- a/SRC/dlangb.f +++ b/SRC/dlangb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlange.f b/SRC/dlange.f index fec96ac7..22c1aea3 100644 --- a/SRC/dlange.f +++ b/SRC/dlange.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlangt.f b/SRC/dlangt.f index d02ed572..172c13a4 100644 --- a/SRC/dlangt.f +++ b/SRC/dlangt.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlanhs.f b/SRC/dlanhs.f index 76b87eeb..b0928fdb 100644 --- a/SRC/dlanhs.f +++ b/SRC/dlanhs.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlansb.f b/SRC/dlansb.f index 1404a571..fa1f90be 100644 --- a/SRC/dlansb.f +++ b/SRC/dlansb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlansf.f b/SRC/dlansf.f new file mode 100644 index 00000000..33cd71c1 --- /dev/null +++ b/SRC/dlansf.f @@ -0,0 +1,860 @@ + DOUBLE PRECISION FUNCTION DLANSF( NORM, TRANSR, UPLO, N, A, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM, TRANSR, UPLO + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ), WORK( 0: * ) +* .. +* +* Purpose +* ======= +* +* DLANSF returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* real symmetric matrix A in RFP format. +* +* Description +* =========== +* +* DLANSF returns the value +* +* DLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER +* Specifies the value to be returned in DLANSF as described +* above. +* +* TRANSR (input) CHARACTER +* Specifies whether the RFP format of A is normal or +* transposed format. +* = 'N': RFP format is Normal; +* = 'T': RFP format is Transpose. +* +* UPLO (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* = 'U': RFP A came from an upper triangular matrix; +* = 'L': RFP A came from a lower triangular matrix. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, DLANSF is +* set to zero. +* +* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); +* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') +* part of the symmetric matrix A stored in RFP format. See the +* "Notes" below for more details. +* Unchanged on exit. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +* WORK is not referenced. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA + DOUBLE PRECISION SCALE, S, VALUE, AA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + DLANSF = ZERO + RETURN + END IF +* +* set noe = 1 if n is odd. if n is even set noe=0 +* + NOE = 1 + IF( MOD( N, 2 ).EQ.0 ) + + NOE = 0 +* +* set ifm = 0 when form='T or 't' and 1 otherwise +* + IFM = 1 + IF( LSAME( TRANSR, 'T' ) ) + + IFM = 0 +* +* set ilu = 0 when uplo='U or 'u' and 1 otherwise +* + ILU = 1 + IF( LSAME( UPLO, 'U' ) ) + + ILU = 0 +* +* set lda = (n+1)/2 when ifm = 0 +* set lda = n when ifm = 1 and noe = 1 +* set lda = n+1 when ifm = 1 and noe = 0 +* + IF( IFM.EQ.1 ) THEN + IF( NOE.EQ.1 ) THEN + LDA = N + ELSE +* noe=0 + LDA = N + 1 + END IF + ELSE +* ifm=0 + LDA = ( N+1 ) / 2 + END IF +* + IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + K = ( N+1 ) / 2 + VALUE = ZERO + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is n by k + DO J = 0, K - 1 + DO I = 0, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* xpose case; A is k by n + DO J = 0, N - 1 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is n+1 by k + DO J = 0, K - 1 + DO I = 0, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* xpose case; A is k by n+1 + DO J = 0, N + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + END IF + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + + ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + IF( IFM.EQ.1 ) THEN + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd + IF( ILU.EQ.0 ) THEN + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + IF( I.EQ.K+K ) + + GO TO 10 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + 10 CONTINUE + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + IF( J.GT.0 ) THEN + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + END IF + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even + IF( ILU.EQ.0 ) THEN + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + ELSE +* ifm=0 + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd + IF( ILU.EQ.0 ) THEN + N1 = K +* n/2 + K = K + 1 +* k is the row size and lda + DO I = N1, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, N1 - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,n1+i) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=n1=k-1 is special + S = ABS( A( 0+J*LDA ) ) +* A(k-1,k-1) + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,i+n1) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K, N - 1 + S = ZERO + DO I = 0, J - K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-k + AA = ABS( A( I+J*LDA ) ) +* A(j-k,j-k) + S = S + AA + WORK( J-K ) = WORK( J-K ) + S + I = I + 1 + S = ABS( A( I+J*LDA ) ) +* A(j,j) + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 2 +* process + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* i=j so process of A(j,j) + S = S + AA + WORK( J ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( A( I+J*LDA ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k-1 is special :process col A(k-1,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K, N - 1 +* process col j of A = A(j,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even + IF( ILU.EQ.0 ) THEN + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i+k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=k + AA = ABS( A( 0+J*LDA ) ) +* A(k,k) + S = AA + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k,k+i) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K + 1, N - 1 + S = ZERO + DO I = 0, J - 2 - K + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-1-k + AA = ABS( A( I+J*LDA ) ) +* A(j-k-1,j-k-1) + S = S + AA + WORK( J-K-1 ) = WORK( J-K-1 ) + S + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,j) + S = AA + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO +* j=n + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(i,k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = WORK( I ) + S + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO +* j=0 is special :process col A(k:n-1,k) + S = ABS( A( 0 ) ) +* A(k,k) + DO I = 1, K - 1 + AA = ABS( A( I ) ) +* A(k+i,k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( K ) = WORK( K ) + S + DO J = 1, K - 1 +* process + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* i=j-1 so process of A(j-1,j-1) + S = S + AA + WORK( J-1 ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( A( I+J*LDA ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k is special :process col A(k,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K + 1, N +* process col j-1 of A = A(j-1,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J-1 ) = WORK( J-1 ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + K = ( N+1 ) / 2 + SCALE = ZERO + S = ONE + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 3 + CALL DLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) +* L at A(k,0) + END DO + DO J = 0, K - 1 + CALL DLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K-1, A( K ), LDA+1, SCALE, S ) +* tri L at A(k,0) + CALL DLASSQ( K, A( K-1 ), LDA+1, SCALE, S ) +* tri U at A(k-1,0) + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL DLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* trap L at A(0,0) + END DO + DO J = 0, K - 2 + CALL DLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri L at A(0,0) + CALL DLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S ) +* tri U at A(0,1) + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 2 + CALL DLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) +* U at A(0,k) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, + + SCALE, S ) +* L at A(0,k-1) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S ) +* tri U at A(0,k) + CALL DLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S ) +* tri L at A(0,k-1) + ELSE +* A' is lower + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + DO J = K, N - 1 + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,k) + END DO + DO J = 0, K - 3 + CALL DLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) +* L at A(1,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + CALL DLASSQ( K-1, A( 1 ), LDA+1, SCALE, S ) +* tri L at A(1,0) + END IF + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) +* L at A(k+1,0) + END DO + DO J = 0, K - 1 + CALL DLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( K+1 ), LDA+1, SCALE, S ) +* tri L at A(k+1,0) + CALL DLASSQ( K, A( K ), LDA+1, SCALE, S ) +* tri U at A(k,0) + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL DLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) +* trap L at A(1,0) + END DO + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 1 ), LDA+1, SCALE, S ) +* tri L at A(1,0) + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) +* U at A(0,k+1) + END DO + DO J = 0, K - 1 + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, + + S ) +* L at A(0,k) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S ) +* tri U at A(0,k+1) + CALL DLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S ) +* tri L at A(0,k) + ELSE +* A' is lower + DO J = 1, K - 1 + CALL DLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + DO J = K + 1, N + CALL DLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,k+1) + END DO + DO J = 0, K - 2 + CALL DLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* L at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL DLASSQ( K, A( LDA ), LDA+1, SCALE, S ) +* tri L at A(0,1) + CALL DLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + END IF + END IF + END IF + VALUE = SCALE*SQRT( S ) + END IF +* + DLANSF = VALUE + RETURN +* +* End of DLANSF +* + END diff --git a/SRC/dlansp.f b/SRC/dlansp.f index ab221006..287f86bb 100644 --- a/SRC/dlansp.f +++ b/SRC/dlansp.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlanst.f b/SRC/dlanst.f index 2b12091a..a6906ca7 100644 --- a/SRC/dlanst.f +++ b/SRC/dlanst.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlansy.f b/SRC/dlansy.f index b6c727c0..36bf82a2 100644 --- a/SRC/dlansy.f +++ b/SRC/dlansy.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlantb.f b/SRC/dlantb.f index 1c6490e8..dacfd701 100644 --- a/SRC/dlantb.f +++ b/SRC/dlantb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlantp.f b/SRC/dlantp.f index 5a04edad..0676a501 100644 --- a/SRC/dlantp.f +++ b/SRC/dlantp.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlantr.f b/SRC/dlantr.f index 92debd3d..5e7fd598 100644 --- a/SRC/dlantr.f +++ b/SRC/dlantr.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlanv2.f b/SRC/dlanv2.f index cef3f472..a07f86ac 100644 --- a/SRC/dlanv2.f +++ b/SRC/dlanv2.f @@ -1,6 +1,6 @@ SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlapll.f b/SRC/dlapll.f index 7eb63f28..583a9247 100644 --- a/SRC/dlapll.f +++ b/SRC/dlapll.f @@ -1,6 +1,6 @@ SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlapmt.f b/SRC/dlapmt.f index 325774c0..a55fdb40 100644 --- a/SRC/dlapmt.f +++ b/SRC/dlapmt.f @@ -1,6 +1,6 @@ SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlapy2.f b/SRC/dlapy2.f index 98ef81b6..6cd95749 100644 --- a/SRC/dlapy2.f +++ b/SRC/dlapy2.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlapy3.f b/SRC/dlapy3.f index 2b47bb47..11a6def9 100644 --- a/SRC/dlapy3.f +++ b/SRC/dlapy3.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqgb.f b/SRC/dlaqgb.f index 97ffab67..390a399e 100644 --- a/SRC/dlaqgb.f +++ b/SRC/dlaqgb.f @@ -1,7 +1,7 @@ SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqge.f b/SRC/dlaqge.f index 9feb927c..eacfc6c9 100644 --- a/SRC/dlaqge.f +++ b/SRC/dlaqge.f @@ -1,7 +1,7 @@ SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqp2.f b/SRC/dlaqp2.f index 5ed16764..cb2e23f6 100644 --- a/SRC/dlaqp2.f +++ b/SRC/dlaqp2.f @@ -1,7 +1,7 @@ SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqps.f b/SRC/dlaqps.f index 2af4e0a4..49a4d2b3 100644 --- a/SRC/dlaqps.f +++ b/SRC/dlaqps.f @@ -1,7 +1,7 @@ SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqr0.f b/SRC/dlaqr0.f index 479da53d..166a5fbb 100644 --- a/SRC/dlaqr0.f +++ b/SRC/dlaqr0.f @@ -1,8 +1,8 @@ SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -73,7 +73,7 @@ * WR (output) DOUBLE PRECISION array, dimension (IHI) * WI (output) DOUBLE PRECISION array, dimension (IHI) * The real and imaginary parts, respectively, of the computed -* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) +* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) * and WI(ILO:IHI). If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with @@ -152,14 +152,12 @@ * If INFO .GT. 0 and WANTZ is .FALSE., then Z is not * accessed. * -* * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * * ================================================================ -* * References: * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR * Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 @@ -176,20 +174,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== DOUBLE PRECISION WILK1, WILK2 PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) DOUBLE PRECISION ZERO, ONE @@ -199,9 +200,9 @@ DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -227,24 +228,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use DLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use DLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -259,6 +245,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -268,7 +267,6 @@ NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -319,6 +317,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -357,50 +356,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. - $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/dlaqr1.f b/SRC/dlaqr1.f index c80fe668..ae23573c 100644 --- a/SRC/dlaqr1.f +++ b/SRC/dlaqr1.f @@ -1,7 +1,7 @@ SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. diff --git a/SRC/dlaqr2.f b/SRC/dlaqr2.f index 6ddb3309..257e25c1 100644 --- a/SRC/dlaqr2.f +++ b/SRC/dlaqr2.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -82,7 +82,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the orthogonal * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -176,7 +176,7 @@ * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, - $ DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC + $ DLANV2, DLARF, DLARFG, DLASET, DORMHR, DTREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT @@ -195,9 +195,10 @@ CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to DORGHR ==== +* ==== Workspace query call to DORMHR ==== * - CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== @@ -216,6 +217,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -255,6 +257,7 @@ IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -332,7 +335,7 @@ NS = NS - 2 ELSE * -* ==== Undflatable. Move them up out of the way. +* ==== Undeflatable. Move them up out of the way. * . Fortunately, DTREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * @@ -478,18 +481,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of DORGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/dlaqr3.f b/SRC/dlaqr3.f index 877b267a..52b5999f 100644 --- a/SRC/dlaqr3.f +++ b/SRC/dlaqr3.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -78,7 +78,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI) +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the orthogonal * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -153,7 +153,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) @@ -173,7 +173,7 @@ * .. * .. External Subroutines .. EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR, - $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR, + $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORMHR, $ DTREXC * .. * .. Intrinsic Functions .. @@ -193,9 +193,10 @@ CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to DORGHR ==== +* ==== Workspace query call to DORMHR ==== * - CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to DLAQR4 ==== @@ -220,6 +221,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -259,6 +261,7 @@ IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -342,7 +345,7 @@ NS = NS - 2 ELSE * -* ==== Undflatable. Move them up out of the way. +* ==== Undeflatable. Move them up out of the way. * . Fortunately, DTREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * @@ -488,18 +491,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of DORGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL DORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/dlaqr4.f b/SRC/dlaqr4.f index 8692e7f9..31b77d1f 100644 --- a/SRC/dlaqr4.f +++ b/SRC/dlaqr4.f @@ -1,8 +1,8 @@ SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -80,7 +80,7 @@ * WR (output) DOUBLE PRECISION array, dimension (IHI) * WI (output) DOUBLE PRECISION array, dimension (IHI) * The real and imaginary parts, respectively, of the computed -* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) +* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) * and WI(ILO:IHI). If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with @@ -181,20 +181,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . DLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== DOUBLE PRECISION WILK1, WILK2 PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 ) DOUBLE PRECISION ZERO, ONE @@ -204,9 +207,9 @@ DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -232,24 +235,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use DLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use DLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -264,6 +252,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -273,7 +274,6 @@ NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -324,6 +324,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -362,50 +363,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. - $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/dlaqr5.f b/SRC/dlaqr5.f index 17857572..53c3101d 100644 --- a/SRC/dlaqr5.f +++ b/SRC/dlaqr5.f @@ -2,7 +2,7 @@ $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, $ LDU, NV, WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -58,11 +58,12 @@ * NSHFTS gives the number of simultaneous shifts. NSHFTS * must be positive and even. * -* SR (input) DOUBLE PRECISION array of size (NSHFTS) -* SI (input) DOUBLE PRECISION array of size (NSHFTS) +* SR (input/output) DOUBLE PRECISION array of size (NSHFTS) +* SI (input/output) DOUBLE PRECISION array of size (NSHFTS) * SR contains the real parts and SI contains the imaginary * parts of the NSHFTS shifts of origin that define the -* multi-shift QR sweep. +* multi-shift QR sweep. On output SR and SI may be +* reordered. * * H (input/output) DOUBLE PRECISION array of size (LDH,N) * On input H contains a Hessenberg matrix. On output a @@ -123,13 +124,12 @@ * LDWV is the leading dimension of WV as declared in the * in the calling subroutine. LDWV.GE.NV. * -* * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ============================================================ +* ================================================================ * Reference: * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR @@ -137,7 +137,7 @@ * Level 3 Performance, SIAM Journal of Matrix Analysis, * volume 23, pages 929--947, 2002. * -* ============================================================ +* ================================================================ * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) @@ -200,7 +200,7 @@ END IF 10 CONTINUE * -* ==== NSHFTS is supposed to be even, but if is odd, +* ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. The shuffle above * . ensures that the dropped shift is real and that * . the remaining shifts are paired. ==== @@ -289,19 +289,12 @@ CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant -* . deflation or destructive underflow. (The -* . initial bulge is always collapsed.) Use -* . the two-small-subdiagonals trick to try -* . to get it started again. If V(2,M).NE.0 and -* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then -* . this bulge is collapsing into a zero -* . subdiagonal. It will be restarted next -* . trip through the loop.) -* - IF( V( 1, M ).NE.ZERO .AND. - $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, - $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) - $ THEN +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * @@ -311,46 +304,31 @@ ELSE * * ==== Atypical case: collapsed. Attempt to -* . reintroduce ignoring H(K+1,K). If the -* . fill resulting from the new reflector -* . is too large, then abandon it. +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ VT ) - SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) + - $ ABS( VT( 3 ) ) - IF( SCL.NE.ZERO ) THEN - VT( 1 ) = VT( 1 ) / SCL - VT( 2 ) = VT( 2 ) / SCL - VT( 3 ) = VT( 3 ) / SCL - END IF + ALPHA = VT( 1 ) + CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* + $ H( K+2, K ) ) * -* ==== The following is the traditional and -* . conservative two-small-subdiagonals -* . test. ==== -* . - IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+ - $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )* + IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would -* . create non-negligible fill. If -* . the old reflector is diagonal (only -* . possible with underflows), then -* . change it to I. Otherwise, use -* . it with trepidation. ==== -* - IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) - $ THEN - V( 1, M ) = ZERO - ELSE - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - END IF +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would @@ -358,11 +336,7 @@ * . Replace the old reflector with * . the new one. ==== * - ALPHA = VT( 1 ) - CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) + - $ H( K+3, K )*VT( 3 ) - H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) @@ -390,12 +364,6 @@ H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF - ELSE -* -* ==== Initialize V(1,M22) here to avoid possible undefined -* . variable problems later. ==== -* - V( 1, M22 ) = ZERO END IF * * ==== Multiply H by reflections from the left ==== @@ -682,7 +650,7 @@ CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * -* ==== Copy top of H bottom of WH ==== +* ==== Copy top of H to bottom of WH ==== * CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) diff --git a/SRC/dlaqsb.f b/SRC/dlaqsb.f index d357bee1..9cf849e3 100644 --- a/SRC/dlaqsb.f +++ b/SRC/dlaqsb.f @@ -1,6 +1,6 @@ SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqsp.f b/SRC/dlaqsp.f index 70f34879..aeb63ae3 100644 --- a/SRC/dlaqsp.f +++ b/SRC/dlaqsp.f @@ -1,6 +1,6 @@ SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqsy.f b/SRC/dlaqsy.f index 23ffe755..d1ddf87e 100644 --- a/SRC/dlaqsy.f +++ b/SRC/dlaqsy.f @@ -1,6 +1,6 @@ SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaqtr.f b/SRC/dlaqtr.f index 73639122..97bb520a 100644 --- a/SRC/dlaqtr.f +++ b/SRC/dlaqtr.f @@ -1,7 +1,7 @@ SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlar1v.f b/SRC/dlar1v.f index 5f04dcc4..799381d8 100644 --- a/SRC/dlar1v.f +++ b/SRC/dlar1v.f @@ -2,7 +2,7 @@ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlar2v.f b/SRC/dlar2v.f index 55bfab90..e3cbd0ec 100644 --- a/SRC/dlar2v.f +++ b/SRC/dlar2v.f @@ -1,6 +1,6 @@ SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarf.f b/SRC/dlarf.f index 70752002..c150b270 100644 --- a/SRC/dlarf.f +++ b/SRC/dlarf.f @@ -1,7 +1,7 @@ SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarfb.f b/SRC/dlarfb.f index d7fb3c51..a375bb6b 100644 --- a/SRC/dlarfb.f +++ b/SRC/dlarfb.f @@ -2,7 +2,7 @@ $ T, LDT, C, LDC, WORK, LDWORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarfg.f b/SRC/dlarfg.f index a569344b..00711492 100644 --- a/SRC/dlarfg.f +++ b/SRC/dlarfg.f @@ -1,6 +1,6 @@ SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarfp.f b/SRC/dlarfp.f index f224f6fb..95ac70e2 100644 --- a/SRC/dlarfp.f +++ b/SRC/dlarfp.f @@ -1,6 +1,6 @@ SUBROUTINE DLARFP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarft.f b/SRC/dlarft.f index 9d2870a9..1277ca13 100644 --- a/SRC/dlarft.f +++ b/SRC/dlarft.f @@ -1,7 +1,7 @@ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -234,13 +234,13 @@ * CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF END IF T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF END IF 40 CONTINUE END IF diff --git a/SRC/dlarfx.f b/SRC/dlarfx.f index 8412acbf..0a40a099 100644 --- a/SRC/dlarfx.f +++ b/SRC/dlarfx.f @@ -1,7 +1,7 @@ SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlargv.f b/SRC/dlargv.f index ca0e9405..766216a3 100644 --- a/SRC/dlargv.f +++ b/SRC/dlargv.f @@ -1,6 +1,6 @@ SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarnv.f b/SRC/dlarnv.f index bc3273c0..cfaa4d62 100644 --- a/SRC/dlarnv.f +++ b/SRC/dlarnv.f @@ -1,6 +1,6 @@ SUBROUTINE DLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarra.f b/SRC/dlarra.f index 44f2a455..63f512bc 100644 --- a/SRC/dlarra.f +++ b/SRC/dlarra.f @@ -2,7 +2,7 @@ $ NSPLIT, ISPLIT, INFO ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrb.f b/SRC/dlarrb.f index ede18985..ab022a45 100644 --- a/SRC/dlarrb.f +++ b/SRC/dlarrb.f @@ -2,7 +2,7 @@ $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, TWIST, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrc.f b/SRC/dlarrc.f index c75b7ef2..9897a499 100644 --- a/SRC/dlarrc.f +++ b/SRC/dlarrc.f @@ -1,7 +1,7 @@ SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN, $ EIGCNT, LCNT, RCNT, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrd.f b/SRC/dlarrd.f index 6cae51b7..21effabf 100644 --- a/SRC/dlarrd.f +++ b/SRC/dlarrd.f @@ -3,7 +3,7 @@ $ M, W, WERR, WL, WU, IBLOCK, INDEXW, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarre.f b/SRC/dlarre.f index 2ba9eef5..0487bd12 100644 --- a/SRC/dlarre.f +++ b/SRC/dlarre.f @@ -4,7 +4,7 @@ $ WORK, IWORK, INFO ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrf.f b/SRC/dlarrf.f index f3ed1efa..6817ac05 100644 --- a/SRC/dlarrf.f +++ b/SRC/dlarrf.f @@ -3,7 +3,7 @@ $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, $ DPLUS, LPLUS, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 ** diff --git a/SRC/dlarrj.f b/SRC/dlarrj.f index 54165837..920f2cf2 100644 --- a/SRC/dlarrj.f +++ b/SRC/dlarrj.f @@ -2,7 +2,7 @@ $ RTOL, OFFSET, W, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrk.f b/SRC/dlarrk.f index 2176e4d7..a3ade115 100644 --- a/SRC/dlarrk.f +++ b/SRC/dlarrk.f @@ -2,7 +2,7 @@ $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrr.f b/SRC/dlarrr.f index 1cc131e9..9b6c7e16 100644 --- a/SRC/dlarrr.f +++ b/SRC/dlarrr.f @@ -1,6 +1,6 @@ SUBROUTINE DLARRR( N, D, E, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarrv.f b/SRC/dlarrv.f index 95d8d6d7..6b30f625 100644 --- a/SRC/dlarrv.f +++ b/SRC/dlarrv.f @@ -4,7 +4,7 @@ $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarscl2.f b/SRC/dlarscl2.f new file mode 100644 index 00000000..e000f6bb --- /dev/null +++ b/SRC/dlarscl2.f @@ -0,0 +1,55 @@ + SUBROUTINE DLARSCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DLARSCL2 performs a reciprocal diagonal scaling on an vector: +* x <-- inv(D) * x +* where the diagonal matrix D is stored as a vector. +* +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) DOUBLE PRECISION array, length N +* Diagonal matrix D, stored as a vector of length N. +* +* X (input/output) DOUBLE PRECISION array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) / D(I) + END DO + END DO +* + RETURN + END diff --git a/SRC/dlartg.f b/SRC/dlartg.f index eb807c1d..d6876e11 100644 --- a/SRC/dlartg.f +++ b/SRC/dlartg.f @@ -1,6 +1,6 @@ SUBROUTINE DLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlartv.f b/SRC/dlartv.f index 8e13cc70..dda512bb 100644 --- a/SRC/dlartv.f +++ b/SRC/dlartv.f @@ -1,6 +1,6 @@ SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaruv.f b/SRC/dlaruv.f index 687c2c45..d8d5cb09 100644 --- a/SRC/dlaruv.f +++ b/SRC/dlaruv.f @@ -1,6 +1,6 @@ SUBROUTINE DLARUV( ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarz.f b/SRC/dlarz.f index b302fdc2..90eb8a5e 100644 --- a/SRC/dlarz.f +++ b/SRC/dlarz.f @@ -1,6 +1,6 @@ SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarzb.f b/SRC/dlarzb.f index ec59d8d5..ba51614c 100644 --- a/SRC/dlarzb.f +++ b/SRC/dlarzb.f @@ -1,7 +1,7 @@ SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlarzt.f b/SRC/dlarzt.f index d79636e0..023ed937 100644 --- a/SRC/dlarzt.f +++ b/SRC/dlarzt.f @@ -1,6 +1,6 @@ SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlas2.f b/SRC/dlas2.f index e100a4d8..c2a40cf7 100644 --- a/SRC/dlas2.f +++ b/SRC/dlas2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlascl.f b/SRC/dlascl.f index efc0685e..0b0de27a 100644 --- a/SRC/dlascl.f +++ b/SRC/dlascl.f @@ -1,6 +1,6 @@ SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlascl2.f b/SRC/dlascl2.f new file mode 100644 index 00000000..025ddaf2 --- /dev/null +++ b/SRC/dlascl2.f @@ -0,0 +1,55 @@ + SUBROUTINE DLASCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DLASCL2 performs a diagonal scaling on a vector: +* x <-- D * x +* where the diagonal matrix D is stored as a vector. +* +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) DOUBLE PRECISION array, length N +* Diagonal matrix D, stored as a vector of length N. +* +* X (input/output) DOUBLE PRECISION array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) * D(I) + END DO + END DO +* + RETURN + END diff --git a/SRC/dlasd0.f b/SRC/dlasd0.f index 0fb5ccc8..8a931e3d 100644 --- a/SRC/dlasd0.f +++ b/SRC/dlasd0.f @@ -1,7 +1,7 @@ SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, $ WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd1.f b/SRC/dlasd1.f index 8b80ba1d..0c33dc7c 100644 --- a/SRC/dlasd1.f +++ b/SRC/dlasd1.f @@ -1,7 +1,7 @@ SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, $ IDXQ, IWORK, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd2.f b/SRC/dlasd2.f index f382de18..9a0b5881 100644 --- a/SRC/dlasd2.f +++ b/SRC/dlasd2.f @@ -2,7 +2,7 @@ $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd3.f b/SRC/dlasd3.f index d4124695..e4932f60 100644 --- a/SRC/dlasd3.f +++ b/SRC/dlasd3.f @@ -2,7 +2,7 @@ $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd4.f b/SRC/dlasd4.f index 795639fd..dca05803 100644 --- a/SRC/dlasd4.f +++ b/SRC/dlasd4.f @@ -1,6 +1,6 @@ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd5.f b/SRC/dlasd5.f index 93cb847d..acb15fbe 100644 --- a/SRC/dlasd5.f +++ b/SRC/dlasd5.f @@ -1,6 +1,6 @@ SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd6.f b/SRC/dlasd6.f index 622befaa..776868b3 100644 --- a/SRC/dlasd6.f +++ b/SRC/dlasd6.f @@ -3,7 +3,7 @@ $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd7.f b/SRC/dlasd7.f index 27547aaa..34ec10a1 100644 --- a/SRC/dlasd7.f +++ b/SRC/dlasd7.f @@ -3,7 +3,7 @@ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ C, S, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasd8.f b/SRC/dlasd8.f index 4121519d..710c0bf9 100644 --- a/SRC/dlasd8.f +++ b/SRC/dlasd8.f @@ -1,9 +1,9 @@ SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, $ DSIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* October 2006 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, K, LDDIFR @@ -42,9 +42,10 @@ * D (output) DOUBLE PRECISION array, dimension ( K ) * On output, D contains the updated singular values. * -* Z (input) DOUBLE PRECISION array, dimension ( K ) -* The first K elements of this array contain the components -* of the deflation-adjusted updating row vector. +* Z (input/output) DOUBLE PRECISION array, dimension ( K ) +* On entry, the first K elements of this array contain the +* components of the deflation-adjusted updating row vector. +* On exit, Z is updated. * * VF (input/output) DOUBLE PRECISION array, dimension ( K ) * On entry, VF contains information passed through DBEDE8. @@ -73,10 +74,12 @@ * LDDIFR (input) INTEGER * The leading dimension of DIFR, must be at least K. * -* DSIGMA (input) DOUBLE PRECISION array, dimension ( K ) -* The first K elements of this array contain the old roots -* of the deflated updating problem. These are the poles +* DSIGMA (input/output) DOUBLE PRECISION array, dimension ( K ) +* On entry, the first K elements of this array contain the old +* roots of the deflated updating problem. These are the poles * of the secular equation. +* On exit, the elements of DSIGMA may be very slightly altered +* in value. * * WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K * @@ -156,7 +159,7 @@ * changes the bottommost bits of DSIGMA(I). It does not account * for hexadecimal or decimal machines without guard digits * (we know of none). We use a subroutine call to compute -* 2*DSIGMA(I) to prevent optimizing compilers from eliminating +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating * this code. * DO 10 I = 1, K @@ -251,3 +254,4 @@ * End of DLASD8 * END + diff --git a/SRC/dlasda.f b/SRC/dlasda.f index fe8f33ec..4061808b 100644 --- a/SRC/dlasda.f +++ b/SRC/dlasda.f @@ -2,7 +2,7 @@ $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasdq.f b/SRC/dlasdq.f index 08f7e8f8..62774e42 100644 --- a/SRC/dlasdq.f +++ b/SRC/dlasdq.f @@ -1,7 +1,7 @@ SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, $ U, LDU, C, LDC, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasdt.f b/SRC/dlasdt.f index b2b8eee6..9033fa49 100644 --- a/SRC/dlasdt.f +++ b/SRC/dlasdt.f @@ -1,6 +1,6 @@ SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaset.f b/SRC/dlaset.f index fc7bc2f5..662cca3b 100644 --- a/SRC/dlaset.f +++ b/SRC/dlaset.f @@ -1,6 +1,6 @@ SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasq1.f b/SRC/dlasq1.f index 6f4c3413..53fd3ddd 100644 --- a/SRC/dlasq1.f +++ b/SRC/dlasq1.f @@ -1,8 +1,14 @@ SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/SRC/dlasq2.f b/SRC/dlasq2.f index b6b79aeb..1fef65b1 100644 --- a/SRC/dlasq2.f +++ b/SRC/dlasq2.f @@ -1,10 +1,14 @@ SUBROUTINE DLASQ2( N, Z, INFO ) * -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- * -* Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH. +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER INFO, N @@ -30,7 +34,7 @@ * Note : DLASQ2 defines a logical variable, IEEE, which is true * on machines which follow ieee-754 floating-point standard in their * handling of infinities and NaNs, and false otherwise. This variable -* is passed to DLAZQ3. +* is passed to DLASQ3. * * Arguments * ========= @@ -38,7 +42,7 @@ * N (input) INTEGER * The number of rows and columns in the matrix. N >= 0. * -* Z (workspace) DOUBLE PRECISION array, dimension ( 4*N ) +* Z (input/output) DOUBLE PRECISION array, dimension ( 4*N ) * On entry Z holds the qd array. On exit, entries 1 to N hold * the eigenvalues in decreasing order, Z( 2*N+1 ) holds the * trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If @@ -76,14 +80,15 @@ * .. * .. Local Scalars .. LOGICAL IEEE - INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, - $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE - DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, - $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN, - $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX + INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, + $ KMIN, N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE + DOUBLE PRECISION D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, + $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, + $ TOL2, TRACE, ZMAX * .. * .. External Subroutines .. - EXTERNAL DLAZQ3, DLASRT, XERBLA + EXTERNAL DLASQ3, DLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV @@ -287,7 +292,7 @@ PP = 1 - PP 80 CONTINUE * -* Initialise variables to pass to DLAZQ3 +* Initialise variables to pass to DLASQ3. * TTYPE = 0 DMIN1 = ZERO @@ -295,15 +300,16 @@ DN = ZERO DN1 = ZERO DN2 = ZERO + G = ZERO TAU = ZERO * ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) * - DO 140 IWHILA = 1, N + 1 + DO 160 IWHILA = 1, N + 1 IF( N0.LT.1 ) - $ GO TO 150 + $ GO TO 170 * * While array unfinished do * @@ -346,29 +352,60 @@ * 100 CONTINUE I0 = I4 / 4 -* -* Store EMIN for passing to DLAZQ3. -* - Z( 4*N0-1 ) = EMIN + PP = 0 +* + IF( N0-I0.GT.1 ) THEN + DEE = Z( 4*I0-3 ) + DEEMIN = DEE + KMIN = I0 + DO 110 I4 = 4*I0+1, 4*N0-3, 4 + DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) + IF( DEE.LE.DEEMIN ) THEN + DEEMIN = DEE + KMIN = ( I4+3 )/4 + END IF + 110 CONTINUE + IF( (KMIN-I0)*2.LT.N0-KMIN .AND. + $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN + IPN4 = 4*( I0+N0 ) + PP = 2 + DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( I4-3 ) + Z( I4-3 ) = Z( IPN4-I4-3 ) + Z( IPN4-I4-3 ) = TEMP + TEMP = Z( I4-2 ) + Z( I4-2 ) = Z( IPN4-I4-2 ) + Z( IPN4-I4-2 ) = TEMP + TEMP = Z( I4-1 ) + Z( I4-1 ) = Z( IPN4-I4-5 ) + Z( IPN4-I4-5 ) = TEMP + TEMP = Z( I4 ) + Z( I4 ) = Z( IPN4-I4-4 ) + Z( IPN4-I4-4 ) = TEMP + 120 CONTINUE + END IF + END IF * * Put -(initial shift) into DMIN. * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * -* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. -* - PP = 0 +* Now I0:N0 is unreduced. +* PP = 0 for ping, PP = 1 for pong. +* PP = 2 indicates that flipping was applied to the Z array and +* and that the tests for deflation upon entry in DLASQ3 +* should not be performed. * NBIG = 30*( N0-I0+1 ) - DO 120 IWHILB = 1, NBIG + DO 140 IWHILB = 1, NBIG IF( I0.GT.N0 ) - $ GO TO 130 + $ GO TO 150 * * While submatrix unfinished take a good dqds step. * - CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + CALL DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU ) + $ DN2, G, TAU ) * PP = 1 - PP * @@ -381,7 +418,7 @@ QMAX = Z( 4*I0-3 ) EMIN = Z( 4*I0-1 ) OLDEMN = Z( 4*I0 ) - DO 110 I4 = 4*I0, 4*( N0-3 ), 4 + DO 130 I4 = 4*I0, 4*( N0-3 ), 4 IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN Z( I4-1 ) = -SIGMA @@ -394,45 +431,45 @@ EMIN = MIN( EMIN, Z( I4-1 ) ) OLDEMN = MIN( OLDEMN, Z( I4 ) ) END IF - 110 CONTINUE + 130 CONTINUE Z( 4*N0-1 ) = EMIN Z( 4*N0 ) = OLDEMN I0 = SPLT + 1 END IF END IF * - 120 CONTINUE + 140 CONTINUE * INFO = 2 RETURN * * end IWHILB * - 130 CONTINUE + 150 CONTINUE * - 140 CONTINUE + 160 CONTINUE * INFO = 3 RETURN * * end IWHILA * - 150 CONTINUE + 170 CONTINUE * * Move q's to the front. * - DO 160 K = 2, N + DO 180 K = 2, N Z( K ) = Z( 4*K-3 ) - 160 CONTINUE + 180 CONTINUE * * Sort and compute sum of eigenvalues. * CALL DLASRT( 'D', N, Z, IINFO ) * E = ZERO - DO 170 K = N, 1, -1 + DO 190 K = N, 1, -1 E = E + Z( K ) - 170 CONTINUE + 190 CONTINUE * * Store trace, sum(eigenvalues) and information on performance. * diff --git a/SRC/dlasq3.f b/SRC/dlasq3.f index ce4055d8..e5ea244d 100644 --- a/SRC/dlasq3.f +++ b/SRC/dlasq3.f @@ -1,14 +1,22 @@ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE ) + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, G, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, ITER, N0, NDIV, NFAIL, PP - DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA + DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, + $ QMAX, SIGMA, TAU * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) @@ -33,8 +41,11 @@ * Z (input) DOUBLE PRECISION array, dimension ( 4*N ) * Z holds the qd array. * -* PP (input) INTEGER +* PP (input/output) INTEGER * PP=0 for ping, PP=1 for pong. +* PP=2 indicates that flipping was applied to the Z array +* and that the initial tests for deflation should not be +* performed. * * DMIN (output) DOUBLE PRECISION * Minimum value of d. @@ -57,12 +68,16 @@ * NDIV (output) INTEGER * Number of divisions. * -* TTYPE (output) INTEGER -* Shift type. -* * IEEE (input) LOGICAL * Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). * +* TTYPE (input/output) INTEGER +* Shift type. +* +* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) DOUBLE PRECISION +* These are passed as arguments in order to save their values +* between calls to DLASQ3. +* * ===================================================================== * * .. Parameters .. @@ -74,33 +89,23 @@ * .. * .. Local Scalars .. INTEGER IPN4, J4, N0IN, NN, TTYPE - DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, - $ TAU, TEMP, TOL, TOL2 + DOUBLE PRECISION EPS, S, T, TEMP, TOL, TOL2 * .. * .. External Subroutines .. EXTERNAL DLASQ4, DLASQ5, DLASQ6 * .. * .. External Function .. DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH + LOGICAL DISNAN + EXTERNAL DISNAN, DLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. -* .. Save statement .. - SAVE TTYPE - SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU -* .. -* .. Data statement .. - DATA TTYPE / 0 / - DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, - $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO / -* .. * .. Executable Statements .. * N0IN = N0 EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) TOL = EPS*HUNDRD TOL2 = TOL**2 * @@ -162,6 +167,8 @@ GO TO 10 * 50 CONTINUE + IF( PP.EQ.2 ) + $ PP = 0 * * Reverse the qd-array, if warranted. * @@ -196,88 +203,88 @@ END IF END IF * - IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), - $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN -* -* Choose a shift. +* Choose a shift. * - CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE ) + CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE, G ) * -* Call dqds until DMIN > 0. +* Call dqds until DMIN > 0. * - 80 CONTINUE + 70 CONTINUE * - CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE ) + CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE ) * - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 * -* Check status. +* Check status. * - IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN + IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN * -* Success. +* Success. * - GO TO 100 + GO TO 90 * - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. - $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. - $ ABS( DN ).LT.TOL*SIGMA ) THEN + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN * -* Convergence hidden by negative DN. +* Convergence hidden by negative DN. * - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 100 - ELSE IF( DMIN.LT.ZERO ) THEN + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 90 + ELSE IF( DMIN.LT.ZERO ) THEN * -* TAU too big. Select new TAU and try again. +* TAU too big. Select new TAU and try again. * - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN + NFAIL = NFAIL + 1 + IF( TTYPE.LT.-22 ) THEN * -* Failed twice. Play it safe. +* Failed twice. Play it safe. * - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN + TAU = ZERO + ELSE IF( DMIN1.GT.ZERO ) THEN * -* Late failure. Gives excellent shift. +* Late failure. Gives excellent shift. * - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE + TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) + TTYPE = TTYPE - 11 + ELSE * -* Early failure. Divide by 4. +* Early failure. Divide by 4. * - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 80 - ELSE IF( DMIN.NE.DMIN ) THEN + TAU = QURTR*TAU + TTYPE = TTYPE - 12 + END IF + GO TO 70 + ELSE IF( DISNAN( DMIN ) ) THEN * -* NaN. +* NaN. * - TAU = ZERO + IF( TAU.EQ.ZERO ) THEN GO TO 80 ELSE -* -* Possible underflow. Play it safe. -* - GO TO 90 + TAU = ZERO + GO TO 70 END IF + ELSE +* +* Possible underflow. Play it safe. +* + GO TO 80 END IF * * Risk of underflow. * - 90 CONTINUE + 80 CONTINUE CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) NDIV = NDIV + ( N0-I0+2 ) ITER = ITER + 1 TAU = ZERO * - 100 CONTINUE + 90 CONTINUE IF( TAU.LT.SIGMA ) THEN DESIG = DESIG + TAU T = SIGMA + DESIG diff --git a/SRC/dlasq4.f b/SRC/dlasq4.f index db2b6fe5..554062f8 100644 --- a/SRC/dlasq4.f +++ b/SRC/dlasq4.f @@ -1,13 +1,19 @@ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE ) + $ DN1, DN2, TAU, TTYPE, G ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU + DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU * .. * .. Array Arguments .. DOUBLE PRECISION Z( * ) @@ -16,7 +22,7 @@ * Purpose * ======= * -* DLASQ4 computes an approximation TAU to the smallest eigenvalue +* DLASQ4 computes an approximation TAU to the smallest eigenvalue * using values of d from the previous transform. * * I0 (input) INTEGER @@ -31,7 +37,7 @@ * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * -* N0IN (input) INTEGER +* NOIN (input) INTEGER * The value of N0 at start of EIGTEST. * * DMIN (input) DOUBLE PRECISION @@ -58,6 +64,10 @@ * TTYPE (output) INTEGER * Shift type. * +* G (input/output) REAL +* G is passed as an argument in order to save its value between +* calls to DLASQ4. +* * Further Details * =============== * CNST1 = 9/16 @@ -75,17 +85,11 @@ * .. * .. Local Scalars .. INTEGER I4, NN, NP - DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S + DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. -* .. Save statement .. - SAVE G -* .. -* .. Data statement .. - DATA G / ZERO / -* .. * .. Executable Statements .. * * A negative DMIN forces the shift to take that absolute value diff --git a/SRC/dlasq5.f b/SRC/dlasq5.f index a006c99e..294a4819 100644 --- a/SRC/dlasq5.f +++ b/SRC/dlasq5.f @@ -1,9 +1,15 @@ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2, IEEE ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. LOGICAL IEEE @@ -79,7 +85,7 @@ $ RETURN * J4 = 4*I0 + PP - 3 - EMIN = Z( J4+4 ) + EMIN = Z( J4+4 ) D = Z( J4 ) - TAU DMIN = D DMIN1 = -Z( J4 ) @@ -90,7 +96,7 @@ * IF( PP.EQ.0 ) THEN DO 10 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) TEMP = Z( J4+1 ) / Z( J4-2 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) @@ -99,7 +105,7 @@ 10 CONTINUE ELSE DO 20 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) TEMP = Z( J4+2 ) / Z( J4-3 ) D = D*TEMP - TAU DMIN = MIN( DMIN, D ) @@ -108,7 +114,7 @@ 20 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN @@ -133,10 +139,10 @@ * IF( PP.EQ.0 ) THEN DO 30 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-2 ) = D + Z( J4-1 ) + Z( J4-2 ) = D + Z( J4-1 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) ) D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU END IF @@ -145,10 +151,10 @@ 30 CONTINUE ELSE DO 40 J4 = 4*I0, 4*( N0-3 ), 4 - Z( J4-3 ) = D + Z( J4 ) + Z( J4-3 ) = D + Z( J4 ) IF( D.LT.ZERO ) THEN RETURN - ELSE + ELSE Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) ) D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU END IF @@ -157,7 +163,7 @@ 40 CONTINUE END IF * -* Unroll last two steps. +* Unroll last two steps. * DNM2 = D DMIN2 = DMIN diff --git a/SRC/dlasq6.f b/SRC/dlasq6.f index e7eb7d0a..2be20317 100644 --- a/SRC/dlasq6.f +++ b/SRC/dlasq6.f @@ -1,9 +1,15 @@ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER I0, N0, PP diff --git a/SRC/dlasr.f b/SRC/dlasr.f index 7e54bfc7..ac434acf 100644 --- a/SRC/dlasr.f +++ b/SRC/dlasr.f @@ -1,6 +1,6 @@ SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasrt.f b/SRC/dlasrt.f index 37e02178..32caf895 100644 --- a/SRC/dlasrt.f +++ b/SRC/dlasrt.f @@ -1,6 +1,6 @@ SUBROUTINE DLASRT( ID, N, D, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlassq.f b/SRC/dlassq.f index 217e794d..976f638c 100644 --- a/SRC/dlassq.f +++ b/SRC/dlassq.f @@ -1,6 +1,6 @@ SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasv2.f b/SRC/dlasv2.f index 4a00b25d..ec9e27cc 100644 --- a/SRC/dlasv2.f +++ b/SRC/dlasv2.f @@ -1,6 +1,6 @@ SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlaswp.f b/SRC/dlaswp.f index a11a87e9..524a9171 100644 --- a/SRC/dlaswp.f +++ b/SRC/dlaswp.f @@ -1,6 +1,6 @@ SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasy2.f b/SRC/dlasy2.f index 3ff12070..1d59e8f2 100644 --- a/SRC/dlasy2.f +++ b/SRC/dlasy2.f @@ -1,7 +1,7 @@ SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlasyf.f b/SRC/dlasyf.f index 67b9c147..a9997be8 100644 --- a/SRC/dlasyf.f +++ b/SRC/dlasyf.f @@ -1,6 +1,6 @@ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlat2s.f b/SRC/dlat2s.f new file mode 100644 index 00000000..e5bc1328 --- /dev/null +++ b/SRC/dlat2s.f @@ -0,0 +1,103 @@ + SUBROUTINE DLAT2S( UPLO, N, A, LDA, SA, LDSA, INFO ) +* +* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* May 2007 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDSA, N +* .. +* .. Array Arguments .. + REAL SA( LDSA, * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE +* PRECISION triangular matrix, A. +* +* RMAX is the overflow for the SINGLE PRECISION arithmetic +* DLAS2S checks that all the entries of A are between -RMAX and +* RMAX. If not the convertion is aborted and a flag is raised. +* +* This is an auxiliary routine so there is no argument checking. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the N-by-N triangular coefficient matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* SA (output) REAL array, dimension (LDSA,N) +* Only the UPLO part of SA is referenced. On exit, if INFO=0, +* the N-by-N coefficient matrix SA; if INFO>0, the content of +* the UPLO part of SA is unspecified. +* +* LDSA (input) INTEGER +* The leading dimension of the array SA. LDSA >= max(1,M). +* +* INFO (output) INTEGER +* = 0: successful exit. +* = 1: an entry of the matrix A is greater than the SINGLE +* PRECISION overflow threshold, in this case, the content +* of the UPLO part of SA in exit is unspecified. +* +* ========= +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION RMAX + LOGICAL UPPER +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME + EXTERNAL SLAMCH, LSAME +* .. +* .. Executable Statements .. +* + RMAX = SLAMCH( 'O' ) + UPPER = LSAME( UPLO, 'U' ) + IF( UPPER ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) + + THEN + INFO = 1 + GO TO 50 + END IF + SA( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + IF( ( A( I, J ).LT.-RMAX ) .OR. ( A( I, J ).GT.RMAX ) ) + + THEN + INFO = 1 + GO TO 50 + END IF + SA( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + 50 CONTINUE +* + RETURN +* +* End of DLAT2S +* + END diff --git a/SRC/dlatbs.f b/SRC/dlatbs.f index 48d8c2e1..5fcaf80b 100644 --- a/SRC/dlatbs.f +++ b/SRC/dlatbs.f @@ -1,7 +1,7 @@ SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlatdf.f b/SRC/dlatdf.f index 91fa46e3..49494c7b 100644 --- a/SRC/dlatdf.f +++ b/SRC/dlatdf.f @@ -1,7 +1,7 @@ SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlatps.f b/SRC/dlatps.f index 7295e010..f33b0cf1 100644 --- a/SRC/dlatps.f +++ b/SRC/dlatps.f @@ -1,7 +1,7 @@ SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlatrd.f b/SRC/dlatrd.f index 27bf9b98..96b8048b 100644 --- a/SRC/dlatrd.f +++ b/SRC/dlatrd.f @@ -1,6 +1,6 @@ SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlatrs.f b/SRC/dlatrs.f index bbd3a9e4..b530b32d 100644 --- a/SRC/dlatrs.f +++ b/SRC/dlatrs.f @@ -1,7 +1,7 @@ SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlatrz.f b/SRC/dlatrz.f index 9ffd9026..09f9a517 100644 --- a/SRC/dlatrz.f +++ b/SRC/dlatrz.f @@ -1,6 +1,6 @@ SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlatzm.f b/SRC/dlatzm.f index 2467ab60..78cc44a3 100644 --- a/SRC/dlatzm.f +++ b/SRC/dlatzm.f @@ -1,6 +1,6 @@ SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlauu2.f b/SRC/dlauu2.f index 092bdda1..e800acb2 100644 --- a/SRC/dlauu2.f +++ b/SRC/dlauu2.f @@ -1,6 +1,6 @@ SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlauum.f b/SRC/dlauum.f index 4857c522..ea93f9a2 100644 --- a/SRC/dlauum.f +++ b/SRC/dlauum.f @@ -1,6 +1,6 @@ SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dlazq3.f b/SRC/dlazq3.f deleted file mode 100644 index 784248f7..00000000 --- a/SRC/dlazq3.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE - DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX, - $ SIGMA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. -* In case of failure it changes shifts, and tries again until output -* is positive. -* -* Arguments -* ========= -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* DMIN (output) DOUBLE PRECISION -* Minimum value of d. -* -* SIGMA (output) DOUBLE PRECISION -* Sum of shifts used in current segment. -* -* DESIG (input/output) DOUBLE PRECISION -* Lower order part of SIGMA -* -* QMAX (input) DOUBLE PRECISION -* Maximum value of q. -* -* NFAIL (output) INTEGER -* Number of times shift was too big. -* -* ITER (output) INTEGER -* Number of iterations. -* -* NDIV (output) INTEGER -* Number of divisions. -* -* IEEE (input) LOGICAL -* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). -* -* TTYPE (input/output) INTEGER -* Shift type. TTYPE is passed as an argument in order to save -* its value between calls to DLAZQ3 -* -* DMIN1 (input/output) REAL -* DMIN2 (input/output) REAL -* DN (input/output) REAL -* DN1 (input/output) REAL -* DN2 (input/output) REAL -* TAU (input/output) REAL -* These are passed as arguments in order to save their values -* between calls to DLAZQ3 -* -* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1, -* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of -* declaring them in a SAVE statment. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CBIAS - PARAMETER ( CBIAS = 1.50D0 ) - DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD - PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0, - $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER IPN4, J4, N0IN, NN - DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2 -* .. -* .. External Subroutines .. - EXTERNAL DLASQ5, DLASQ6, DLAZQ4 -* .. -* .. External Function .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT -* .. -* .. Executable Statements .. -* - N0IN = N0 - EPS = DLAMCH( 'Precision' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 - G = ZERO -* -* Check for deflation. -* - 10 CONTINUE -* - IF( N0.LT.I0 ) - $ RETURN - IF( N0.EQ.I0 ) - $ GO TO 20 - NN = 4*N0 + PP - IF( N0.EQ.( I0+1 ) ) - $ GO TO 40 -* -* Check whether E(N0-1) is negligible, 1 eigenvalue. -* - IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. - $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) - $ GO TO 30 -* - 20 CONTINUE -* - Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA - N0 = N0 - 1 - GO TO 10 -* -* Check whether E(N0-2) is negligible, 2 eigenvalues. -* - 30 CONTINUE -* - IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. - $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) - $ GO TO 50 -* - 40 CONTINUE -* - IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN - S = Z( NN-3 ) - Z( NN-3 ) = Z( NN-7 ) - Z( NN-7 ) = S - END IF - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - S = Z( NN-3 )*( Z( NN-5 ) / T ) - IF( S.LE.T ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / - $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( NN-7 ) + ( S+Z( NN-5 ) ) - Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) - Z( NN-7 ) = T - END IF - Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA - Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA - N0 = N0 - 2 - GO TO 10 -* - 50 CONTINUE -* -* Reverse the qd-array, if warranted. -* - IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN - IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( J4-3 ) - Z( J4-3 ) = Z( IPN4-J4-3 ) - Z( IPN4-J4-3 ) = TEMP - TEMP = Z( J4-2 ) - Z( J4-2 ) = Z( IPN4-J4-2 ) - Z( IPN4-J4-2 ) = TEMP - TEMP = Z( J4-1 ) - Z( J4-1 ) = Z( IPN4-J4-5 ) - Z( IPN4-J4-5 ) = TEMP - TEMP = Z( J4 ) - Z( J4 ) = Z( IPN4-J4-4 ) - Z( IPN4-J4-4 ) = TEMP - 60 CONTINUE - IF( N0-I0.LE.4 ) THEN - Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) - Z( 4*N0-PP ) = Z( 4*I0-PP ) - END IF - DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) - Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), - $ Z( 4*I0+PP+3 ) ) - Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), - $ Z( 4*I0-PP+4 ) ) - QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) - DMIN = -ZERO - END IF - END IF -* - IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), - $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN -* -* Choose a shift. -* - CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE, G ) -* -* Call dqds until DMIN > 0. -* - 80 CONTINUE -* - CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE ) -* - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 -* -* Check status. -* - IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN -* -* Success. -* - GO TO 100 -* - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. - $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. - $ ABS( DN ).LT.TOL*SIGMA ) THEN -* -* Convergence hidden by negative DN. -* - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 100 - ELSE IF( DMIN.LT.ZERO ) THEN -* -* TAU too big. Select new TAU and try again. -* - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN -* -* Failed twice. Play it safe. -* - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN -* -* Late failure. Gives excellent shift. -* - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE -* -* Early failure. Divide by 4. -* - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 80 - ELSE IF( DMIN.NE.DMIN ) THEN -* -* NaN. -* - TAU = ZERO - GO TO 80 - ELSE -* -* Possible underflow. Play it safe. -* - GO TO 90 - END IF - END IF -* -* Risk of underflow. -* - 90 CONTINUE - CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 - TAU = ZERO -* - 100 CONTINUE - IF( TAU.LT.SIGMA ) THEN - DESIG = DESIG + TAU - T = SIGMA + DESIG - DESIG = DESIG - ( T-SIGMA ) - ELSE - T = SIGMA + TAU - DESIG = SIGMA - ( T-TAU ) + DESIG - END IF - SIGMA = T -* - RETURN -* -* End of DLAZQ3 -* - END diff --git a/SRC/dlazq4.f b/SRC/dlazq4.f deleted file mode 100644 index 7c257f8d..00000000 --- a/SRC/dlazq4.f +++ /dev/null @@ -1,330 +0,0 @@ - SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE, G ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER I0, N0, N0IN, PP, TTYPE - DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION Z( * ) -* .. -* -* Purpose -* ======= -* -* DLAZQ4 computes an approximation TAU to the smallest eigenvalue -* using values of d from the previous transform. -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) DOUBLE PRECISION array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* N0IN (input) INTEGER -* The value of N0 at start of EIGTEST. -* -* DMIN (input) DOUBLE PRECISION -* Minimum value of d. -* -* DMIN1 (input) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ). -* -* DMIN2 (input) DOUBLE PRECISION -* Minimum value of d, excluding D( N0 ) and D( N0-1 ). -* -* DN (input) DOUBLE PRECISION -* d(N) -* -* DN1 (input) DOUBLE PRECISION -* d(N-1) -* -* DN2 (input) DOUBLE PRECISION -* d(N-2) -* -* TAU (output) DOUBLE PRECISION -* This is the shift. -* -* TTYPE (output) INTEGER -* Shift type. -* -* G (input/output) DOUBLE PRECISION -* G is passed as an argument in order to save its value between -* calls to DLAZQ4 -* -* Further Details -* =============== -* CNST1 = 9/16 -* -* This is a thread safe version of DLASQ4, which passes G through the -* argument list in place of declaring G in a SAVE statment. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION CNST1, CNST2, CNST3 - PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0, - $ CNST3 = 1.050D0 ) - DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD - PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0, - $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0, - $ TWO = 2.0D0, HUNDRD = 100.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I4, NN, NP - DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* A negative DMIN forces the shift to take that absolute value -* TTYPE records the type of shift. -* - IF( DMIN.LE.ZERO ) THEN - TAU = -DMIN - TTYPE = -1 - RETURN - END IF -* - NN = 4*N0 + PP - IF( N0IN.EQ.N0 ) THEN -* -* No eigenvalues deflated. -* - IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN -* - B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) - B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) - A2 = Z( NN-7 ) + Z( NN-5 ) -* -* Cases 2 and 3. -* - IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN - GAP2 = DMIN2 - A2 - DMIN2*QURTR - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN - GAP1 = A2 - DN - ( B2 / GAP2 )*B2 - ELSE - GAP1 = A2 - DN - ( B1+B2 ) - END IF - IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN - S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) - TTYPE = -2 - ELSE - S = ZERO - IF( DN.GT.B1 ) - $ S = DN - B1 - IF( A2.GT.( B1+B2 ) ) - $ S = MIN( S, A2-( B1+B2 ) ) - S = MAX( S, THIRD*DMIN ) - TTYPE = -3 - END IF - ELSE -* -* Case 4. -* - TTYPE = -4 - S = QURTR*DMIN - IF( DMIN.EQ.DN ) THEN - GAM = DN - A2 = ZERO - IF( Z( NN-5 ) .GT. Z( NN-7 ) ) - $ RETURN - B2 = Z( NN-5 ) / Z( NN-7 ) - NP = NN - 9 - ELSE - NP = NN - 2*PP - B2 = Z( NP-2 ) - GAM = DN1 - IF( Z( NP-4 ) .GT. Z( NP-2 ) ) - $ RETURN - A2 = Z( NP-4 ) / Z( NP-2 ) - IF( Z( NN-9 ) .GT. Z( NN-11 ) ) - $ RETURN - B2 = Z( NN-9 ) / Z( NN-11 ) - NP = NN - 13 - END IF -* -* Approximate contribution to norm squared from I < NN-1. -* - A2 = A2 + B2 - DO 10 I4 = NP, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 20 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 20 - 10 CONTINUE - 20 CONTINUE - A2 = CNST3*A2 -* -* Rayleigh quotient residual bound. -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - END IF - ELSE IF( DMIN.EQ.DN2 ) THEN -* -* Case 5. -* - TTYPE = -5 - S = QURTR*DMIN -* -* Compute contribution to norm squared from I > NN-2. -* - NP = NN - 2*PP - B1 = Z( NP-2 ) - B2 = Z( NP-6 ) - GAM = DN2 - IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) - $ RETURN - A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) -* -* Approximate contribution to norm squared from I < NN-2. -* - IF( N0-I0.GT.2 ) THEN - B2 = Z( NN-13 ) / Z( NN-15 ) - A2 = A2 + B2 - DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 40 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - A2 = CNST3*A2 - END IF -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - ELSE -* -* Case 6, no information to guide us. -* - IF( TTYPE.EQ.-6 ) THEN - G = G + THIRD*( ONE-G ) - ELSE IF( TTYPE.EQ.-18 ) THEN - G = QURTR*THIRD - ELSE - G = QURTR - END IF - S = G*DMIN - TTYPE = -6 - END IF -* - ELSE IF( N0IN.EQ.( N0+1 ) ) THEN -* -* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. -* - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN -* -* Cases 7 and 8. -* - TTYPE = -7 - S = THIRD*DMIN1 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 60 - DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - A2 = B1 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) - $ GO TO 60 - 50 CONTINUE - 60 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN1 / ( ONE+B2**2 ) - GAP2 = HALF*DMIN2 - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - TTYPE = -8 - END IF - ELSE -* -* Case 9. -* - S = QURTR*DMIN1 - IF( DMIN1.EQ.DN1 ) - $ S = HALF*DMIN1 - TTYPE = -9 - END IF -* - ELSE IF( N0IN.EQ.( N0+2 ) ) THEN -* -* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. -* -* Cases 10 and 11. -* - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN - TTYPE = -10 - S = THIRD*DMIN2 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 80 - DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*B1.LT.B2 ) - $ GO TO 80 - 70 CONTINUE - 80 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN2 / ( ONE+B2**2 ) - GAP2 = Z( NN-7 ) + Z( NN-9 ) - - $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - END IF - ELSE - S = QURTR*DMIN2 - TTYPE = -11 - END IF - ELSE IF( N0IN.GT.( N0+2 ) ) THEN -* -* Case 12, more than two eigenvalues deflated. No information. -* - S = ZERO - TTYPE = -12 - END IF -* - TAU = S - RETURN -* -* End of DLAZQ4 -* - END diff --git a/SRC/dopgtr.f b/SRC/dopgtr.f index cf0901ff..237cdb6f 100644 --- a/SRC/dopgtr.f +++ b/SRC/dopgtr.f @@ -1,6 +1,6 @@ SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dopmtr.f b/SRC/dopmtr.f index b926594d..bf59dee2 100644 --- a/SRC/dopmtr.f +++ b/SRC/dopmtr.f @@ -1,7 +1,7 @@ SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorg2l.f b/SRC/dorg2l.f index a20965fd..441b83b1 100644 --- a/SRC/dorg2l.f +++ b/SRC/dorg2l.f @@ -1,6 +1,6 @@ SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorg2r.f b/SRC/dorg2r.f index 476e9f70..3dd4005b 100644 --- a/SRC/dorg2r.f +++ b/SRC/dorg2r.f @@ -1,6 +1,6 @@ SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgbr.f b/SRC/dorgbr.f index dc882990..46fc5090 100644 --- a/SRC/dorgbr.f +++ b/SRC/dorgbr.f @@ -1,6 +1,6 @@ SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorghr.f b/SRC/dorghr.f index 1283aece..41c11280 100644 --- a/SRC/dorghr.f +++ b/SRC/dorghr.f @@ -1,6 +1,6 @@ SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgl2.f b/SRC/dorgl2.f index 1e08344d..e98dc765 100644 --- a/SRC/dorgl2.f +++ b/SRC/dorgl2.f @@ -1,6 +1,6 @@ SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorglq.f b/SRC/dorglq.f index e4f58c96..da703729 100644 --- a/SRC/dorglq.f +++ b/SRC/dorglq.f @@ -1,6 +1,6 @@ SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgql.f b/SRC/dorgql.f index 1c4896e9..ad729c64 100644 --- a/SRC/dorgql.f +++ b/SRC/dorgql.f @@ -1,6 +1,6 @@ SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgqr.f b/SRC/dorgqr.f index 4db0ef5a..7da3a54b 100644 --- a/SRC/dorgqr.f +++ b/SRC/dorgqr.f @@ -1,6 +1,6 @@ SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgr2.f b/SRC/dorgr2.f index 9da45c5f..ce84d440 100644 --- a/SRC/dorgr2.f +++ b/SRC/dorgr2.f @@ -1,6 +1,6 @@ SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgrq.f b/SRC/dorgrq.f index 11633403..af5b9b90 100644 --- a/SRC/dorgrq.f +++ b/SRC/dorgrq.f @@ -1,6 +1,6 @@ SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorgtr.f b/SRC/dorgtr.f index 4c72d031..2ecebc80 100644 --- a/SRC/dorgtr.f +++ b/SRC/dorgtr.f @@ -1,6 +1,6 @@ SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorm2l.f b/SRC/dorm2l.f index 27120075..37927850 100644 --- a/SRC/dorm2l.f +++ b/SRC/dorm2l.f @@ -1,7 +1,7 @@ SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorm2r.f b/SRC/dorm2r.f index 79c9ef35..be599498 100644 --- a/SRC/dorm2r.f +++ b/SRC/dorm2r.f @@ -1,7 +1,7 @@ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormbr.f b/SRC/dormbr.f index 8066b893..4be3e831 100644 --- a/SRC/dormbr.f +++ b/SRC/dormbr.f @@ -1,7 +1,7 @@ SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormhr.f b/SRC/dormhr.f index 5862538e..d0557e73 100644 --- a/SRC/dormhr.f +++ b/SRC/dormhr.f @@ -1,7 +1,7 @@ SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dorml2.f b/SRC/dorml2.f index d3941c9a..9079ed73 100644 --- a/SRC/dorml2.f +++ b/SRC/dorml2.f @@ -1,7 +1,7 @@ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormlq.f b/SRC/dormlq.f index f0c68ef2..c14d816c 100644 --- a/SRC/dormlq.f +++ b/SRC/dormlq.f @@ -1,7 +1,7 @@ SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormql.f b/SRC/dormql.f index f3370f10..bf5841fd 100644 --- a/SRC/dormql.f +++ b/SRC/dormql.f @@ -1,7 +1,7 @@ SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormqr.f b/SRC/dormqr.f index ee372695..57c2f0ef 100644 --- a/SRC/dormqr.f +++ b/SRC/dormqr.f @@ -1,7 +1,7 @@ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormr2.f b/SRC/dormr2.f index 994552fb..8e859f9a 100644 --- a/SRC/dormr2.f +++ b/SRC/dormr2.f @@ -1,7 +1,7 @@ SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormr3.f b/SRC/dormr3.f index 7bdcb856..14234d9b 100644 --- a/SRC/dormr3.f +++ b/SRC/dormr3.f @@ -1,7 +1,7 @@ SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormrq.f b/SRC/dormrq.f index 522c1392..f82fd82a 100644 --- a/SRC/dormrq.f +++ b/SRC/dormrq.f @@ -1,7 +1,7 @@ SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dormrz.f b/SRC/dormrz.f index b69d9c63..5a049f09 100644 --- a/SRC/dormrz.f +++ b/SRC/dormrz.f @@ -1,7 +1,7 @@ SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/dormtr.f b/SRC/dormtr.f index 3fe9db0d..fde51fb3 100644 --- a/SRC/dormtr.f +++ b/SRC/dormtr.f @@ -1,7 +1,7 @@ SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbcon.f b/SRC/dpbcon.f index ad5fa41b..f99d38b3 100644 --- a/SRC/dpbcon.f +++ b/SRC/dpbcon.f @@ -1,7 +1,7 @@ SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbequ.f b/SRC/dpbequ.f index cb2016e2..b58d451e 100644 --- a/SRC/dpbequ.f +++ b/SRC/dpbequ.f @@ -1,6 +1,6 @@ SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbrfs.f b/SRC/dpbrfs.f index 992fc984..7ef3905f 100644 --- a/SRC/dpbrfs.f +++ b/SRC/dpbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbstf.f b/SRC/dpbstf.f index b6bf9f38..5e1d588a 100644 --- a/SRC/dpbstf.f +++ b/SRC/dpbstf.f @@ -1,6 +1,6 @@ SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbsv.f b/SRC/dpbsv.f index 4d1b66b0..3ec138a2 100644 --- a/SRC/dpbsv.f +++ b/SRC/dpbsv.f @@ -1,6 +1,6 @@ SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbsvx.f b/SRC/dpbsvx.f index 1bc4d649..75820864 100644 --- a/SRC/dpbsvx.f +++ b/SRC/dpbsvx.f @@ -2,7 +2,7 @@ $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbtf2.f b/SRC/dpbtf2.f index 8419f914..8d18b6b5 100644 --- a/SRC/dpbtf2.f +++ b/SRC/dpbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbtrf.f b/SRC/dpbtrf.f index 1aa19ef2..e9ea5927 100644 --- a/SRC/dpbtrf.f +++ b/SRC/dpbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpbtrs.f b/SRC/dpbtrs.f index 76b086a4..4d633760 100644 --- a/SRC/dpbtrs.f +++ b/SRC/dpbtrs.f @@ -1,6 +1,6 @@ SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpftrf.f b/SRC/dpftrf.f new file mode 100644 index 00000000..4451dfb3 --- /dev/null +++ b/SRC/dpftrf.f @@ -0,0 +1,397 @@ + SUBROUTINE DPFTRF( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER N, INFO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ) +* +* Purpose +* ======= +* +* DPFTRF computes the Cholesky factorization of a real symmetric +* positive definite matrix A. +* +* The factorization has the form +* A = U**T * U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular. +* +* This is the block version of the algorithm, calling Level 3 BLAS. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ); +* On entry, the symmetric matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +* the transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the NT elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization RFP A = U**T*U or RFP A = L*L**T. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i is not +* positive definite, and the factorization could not be +* completed. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYRK, DPOTRF, DTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPFTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL DPOTRF( 'L', N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, A( 0 ), N, + + A( N1 ), N ) + CALL DSYRK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE, + + A( N ), N ) + CALL DPOTRF( 'U', N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL DPOTRF( 'L', N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'L', 'L', 'N', 'N', N1, N2, ONE, A( N2 ), N, + + A( 0 ), N ) + CALL DSYRK( 'U', 'T', N2, N1, -ONE, A( 0 ), N, ONE, + + A( N1 ), N ) + CALL DPOTRF( 'U', N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + CALL DPOTRF( 'U', N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, A( 0 ), N1, + + A( N1*N1 ), N1 ) + CALL DSYRK( 'L', 'T', N2, N1, -ONE, A( N1*N1 ), N1, ONE, + + A( 1 ), N1 ) + CALL DPOTRF( 'L', N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + CALL DPOTRF( 'U', N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'R', 'U', 'N', 'N', N2, N1, ONE, A( N2*N2 ), + + N2, A( 0 ), N2 ) + CALL DSYRK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE, + + A( N1*N2 ), N2 ) + CALL DPOTRF( 'L', N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL DPOTRF( 'L', K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'R', 'L', 'T', 'N', K, K, ONE, A( 1 ), N+1, + + A( K+1 ), N+1 ) + CALL DSYRK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE, + + A( 0 ), N+1 ) + CALL DPOTRF( 'U', K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL DPOTRF( 'L', K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'L', 'L', 'N', 'N', K, K, ONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL DSYRK( 'U', 'T', K, K, -ONE, A( 0 ), N+1, ONE, + + A( K ), N+1 ) + CALL DPOTRF( 'U', K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL DPOTRF( 'U', K, A( 0+K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'L', 'U', 'T', 'N', K, K, ONE, A( K ), N1, + + A( K*( K+1 ) ), K ) + CALL DSYRK( 'L', 'T', K, K, -ONE, A( K*( K+1 ) ), K, ONE, + + A( 0 ), K ) + CALL DPOTRF( 'L', K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL DPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRSM( 'R', 'U', 'N', 'N', K, K, ONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL DSYRK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE, + + A( K*K ), K ) + CALL DPOTRF( 'L', K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DPFTRF +* + END diff --git a/SRC/dpftri.f b/SRC/dpftri.f new file mode 100644 index 00000000..674d70c0 --- /dev/null +++ b/SRC/dpftri.f @@ -0,0 +1,362 @@ + SUBROUTINE DPFTRI( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ) +* .. +* +* Purpose +* ======= +* +* DPFTRI computes the inverse of a (real) symmetric positive definite +* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T +* computed by DPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ) +* On entry, the symmetric matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +* the transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, the symmetric inverse of the original matrix, in the +* same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the (i,i) element of the factor U or L is +* zero, and the inverse could not be computed. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DTFTRI, DLAUUM, DTRMM, DSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL DTFTRI( TRANSR, UPLO, 'N', N, A, INFO ) + IF( INFO.GT.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or +* inv(L)^C*inv(L). There are eight cases. +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) +* T1 -> a(0), T2 -> a(n), S -> a(N1) +* + CALL DLAUUM( 'L', N1, A( 0 ), N, INFO ) + CALL DSYRK( 'L', 'T', N1, N2, ONE, A( N1 ), N, ONE, + + A( 0 ), N ) + CALL DTRMM( 'L', 'U', 'N', 'N', N2, N1, ONE, A( N ), N, + + A( N1 ), N ) + CALL DLAUUM( 'U', N2, A( N ), N, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) +* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) +* T1 -> a(N2), T2 -> a(N1), S -> a(0) +* + CALL DLAUUM( 'L', N1, A( N2 ), N, INFO ) + CALL DSYRK( 'L', 'N', N1, N2, ONE, A( 0 ), N, ONE, + + A( N2 ), N ) + CALL DTRMM( 'R', 'U', 'T', 'N', N1, N2, ONE, A( N1 ), N, + + A( 0 ), N ) + CALL DLAUUM( 'U', N2, A( N1 ), N, INFO ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) +* + CALL DLAUUM( 'U', N1, A( 0 ), N1, INFO ) + CALL DSYRK( 'U', 'N', N1, N2, ONE, A( N1*N1 ), N1, ONE, + + A( 0 ), N1 ) + CALL DTRMM( 'R', 'L', 'N', 'N', N1, N2, ONE, A( 1 ), N1, + + A( N1*N1 ), N1 ) + CALL DLAUUM( 'L', N2, A( 1 ), N1, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is odd +* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) +* + CALL DLAUUM( 'U', N1, A( N2*N2 ), N2, INFO ) + CALL DSYRK( 'U', 'T', N1, N2, ONE, A( 0 ), N2, ONE, + + A( N2*N2 ), N2 ) + CALL DTRMM( 'L', 'L', 'T', 'N', N2, N1, ONE, A( N1*N2 ), + + N2, A( 0 ), N2 ) + CALL DLAUUM( 'L', N2, A( N1*N2 ), N2, INFO ) +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL DLAUUM( 'L', K, A( 1 ), N+1, INFO ) + CALL DSYRK( 'L', 'T', K, K, ONE, A( K+1 ), N+1, ONE, + + A( 1 ), N+1 ) + CALL DTRMM( 'L', 'U', 'N', 'N', K, K, ONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) + CALL DLAUUM( 'U', K, A( 0 ), N+1, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL DLAUUM( 'L', K, A( K+1 ), N+1, INFO ) + CALL DSYRK( 'L', 'N', K, K, ONE, A( 0 ), N+1, ONE, + + A( K+1 ), N+1 ) + CALL DTRMM( 'R', 'U', 'T', 'N', K, K, ONE, A( K ), N+1, + + A( 0 ), N+1 ) + CALL DLAUUM( 'U', K, A( K ), N+1, INFO ) +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL DLAUUM( 'U', K, A( K ), K, INFO ) + CALL DSYRK( 'U', 'N', K, K, ONE, A( K*( K+1 ) ), K, ONE, + + A( K ), K ) + CALL DTRMM( 'R', 'L', 'N', 'N', K, K, ONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + CALL DLAUUM( 'L', K, A( 0 ), K, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL DLAUUM( 'U', K, A( K*( K+1 ) ), K, INFO ) + CALL DSYRK( 'U', 'T', K, K, ONE, A( 0 ), K, ONE, + + A( K*( K+1 ) ), K ) + CALL DTRMM( 'L', 'L', 'T', 'N', K, K, ONE, A( K*K ), K, + + A( 0 ), K ) + CALL DLAUUM( 'L', K, A( K*K ), K, INFO ) +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DPFTRI +* + END diff --git a/SRC/dpftrs.f b/SRC/dpftrs.f new file mode 100644 index 00000000..2f1287cc --- /dev/null +++ b/SRC/dpftrs.f @@ -0,0 +1,209 @@ + SUBROUTINE DPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DPFTRS solves a system of linear equations A*X = B with a symmetric +* positive definite matrix A using the Cholesky factorization +* A = U**T*U or A = L*L**T computed by DPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ). +* The triangular factor U or L from the Cholesky factorization +* of RFP A = U**T*U or RFP A = L*L**T, as computed by DPFTRF. +* See note below for more details about RFP A. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DTFSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPFTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + + RETURN +* +* start execution: there are two triangular solves +* + IF( LOWER ) THEN + CALL DTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, + + LDB ) + CALL DTFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, + + LDB ) + ELSE + CALL DTFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, + + LDB ) + CALL DTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, + + LDB ) + END IF +* + RETURN +* +* End of DPFTRS +* + END diff --git a/SRC/dpocon.f b/SRC/dpocon.f index c28af374..ba41cdcc 100644 --- a/SRC/dpocon.f +++ b/SRC/dpocon.f @@ -1,7 +1,7 @@ SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpoequ.f b/SRC/dpoequ.f index a5baa17c..4ee9fded 100644 --- a/SRC/dpoequ.f +++ b/SRC/dpoequ.f @@ -1,6 +1,6 @@ SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpoequb.f b/SRC/dpoequb.f new file mode 100644 index 00000000..81086e31 --- /dev/null +++ b/SRC/dpoequb.f @@ -0,0 +1,152 @@ + SUBROUTINE DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ) +* .. +* +* Purpose +* ======= +* +* DPOEQU computes row and column scalings intended to equilibrate a +* symmetric positive definite matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N symmetric positive definite matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) DOUBLE PRECISION +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION SMIN, BASE, TMP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, LOG, INT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* +* Positive definite only performs 1 pass of equilibration. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF + + BASE = DLAMCH( 'B' ) + TMP = -0.5D+0 / LOG ( BASE ) +* +* Find the minimum and maximum diagonal elements. +* + S( 1 ) = A( 1, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) + DO 10 I = 2, N + S( I ) = A( I, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = BASE ** INT( TMP * LOG( S( I ) ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)). +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF +* + RETURN +* +* End of DPOEQUB +* + END diff --git a/SRC/dporfs.f b/SRC/dporfs.f index 5a34b611..e4e68fd5 100644 --- a/SRC/dporfs.f +++ b/SRC/dporfs.f @@ -1,7 +1,7 @@ SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dporfsx.f b/SRC/dporfsx.f new file mode 100644 index 00000000..41a3b946 --- /dev/null +++ b/SRC/dporfsx.f @@ -0,0 +1,568 @@ + SUBROUTINE DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, + $ LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DPORFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric positive +* definite, and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular part +* of the matrix A, and the strictly lower triangular part of A +* is not referenced. If UPLO = 'L', the leading N-by-N lower +* triangular part of A contains the lower triangular part of +* the matrix A, and the strictly upper triangular part of A is +* not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) +* The triangular factor U or L from the Cholesky factorization +* A = U**T*U or A = L*L**T, as computed by DPOTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 100.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DPOCON, DLA_PORFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, DLANSY, DLA_PORCOND + DOUBLE PRECISION DLAMCH, DLANSY, DLA_PORCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME(UPLO, 'U') .AND. .NOT.LSAME(UPLO, 'L')) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPORFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = DLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL DLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), WORK( 1 ), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ -1, S, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ 0, S, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF (N_ERR_BNDS .GE. LA_LINRX_RCOND_I) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, 1, + $ X( 1, J ), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of DPORFSX +* + END diff --git a/SRC/dposv.f b/SRC/dposv.f index a52c2629..c2343e17 100644 --- a/SRC/dposv.f +++ b/SRC/dposv.f @@ -1,6 +1,6 @@ SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dposvx.f b/SRC/dposvx.f index b6083baa..58099dec 100644 --- a/SRC/dposvx.f +++ b/SRC/dposvx.f @@ -2,7 +2,7 @@ $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dposvxx.f b/SRC/dposvxx.f new file mode 100644 index 00000000..7164ae31 --- /dev/null +++ b/SRC/dposvxx.f @@ -0,0 +1,551 @@ + SUBROUTINE DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, + $ S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T +* to compute the solution to a double precision system of linear equations +* A * X = B, where A is an N-by-N symmetric positive definite matrix +* and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. DPOSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* DPOSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* DPOSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what DPOSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +* factor the matrix A (after equilibration if FACT = 'E') as +* A = U**T* U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is a lower triangular +* matrix. +* +* 3. If the leading i-by-i principal minor is not positive definite, +* then the routine returns with INFO = i. Otherwise, the factored +* form of A is used to estimate the condition number of the matrix +* A (see argument RCOND). If the reciprocal of the condition number +* is less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(S) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF contains the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A and AF are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = +* 'Y', then A must contain the equilibrated matrix +* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper +* triangular part of A contains the upper triangular part of the +* matrix A, and the strictly lower triangular part of A is not +* referenced. If UPLO = 'L', the leading N-by-N lower triangular +* part of A contains the lower triangular part of the matrix A, and +* the strictly upper triangular part of A is not referenced. A is +* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = +* 'N' on exit. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T, in the same storage +* format as A. If EQUED .ne. 'N', then AF is the factored +* form of the equilibrated matrix diag(S)*A*diag(S). +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the original +* matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the equilibrated +* matrix A (see the description of A for the form of the +* equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, + $ SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_PORPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_PORPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DPOEQUB, DPOTRF, DPOTRS, DLACPY, DLAQSY, + $ XERBLA, DLASCL2, DPORFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DPORFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DPORFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DPOEQUB( N, A, LDA, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL DLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL DPOTRF( UPLO, N, AF, LDAF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.NE.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = DLA_PORPVGRW( UPLO, INFO, A, LDA, AF, LDAF, WORK ) + RETURN + ENDIF + END IF +* +* Compute the reciprocal growth factor RPVGRW. +* + RPVGRW = DLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO ) + +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL DLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of DPOSVXX +* + END diff --git a/SRC/dpotf2.f b/SRC/dpotf2.f index b7d65e91..5c148895 100644 --- a/SRC/dpotf2.f +++ b/SRC/dpotf2.f @@ -1,6 +1,6 @@ SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -71,9 +71,9 @@ DOUBLE PRECISION AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, DISNAN DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT + EXTERNAL LSAME, DDOT, DISNAN * .. * .. External Subroutines .. EXTERNAL DGEMV, DSCAL, XERBLA @@ -113,7 +113,7 @@ * Compute U(J,J) and test for non-positive-definiteness. * AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF @@ -138,7 +138,7 @@ * AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), $ LDA ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF diff --git a/SRC/dpotrf.f b/SRC/dpotrf.f index 8449df6d..d9fd2524 100644 --- a/SRC/dpotrf.f +++ b/SRC/dpotrf.f @@ -1,6 +1,6 @@ SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpotri.f b/SRC/dpotri.f index 7f7b1d06..4c2f3e80 100644 --- a/SRC/dpotri.f +++ b/SRC/dpotri.f @@ -1,6 +1,6 @@ SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpotrs.f b/SRC/dpotrs.f index 0273655e..111bb694 100644 --- a/SRC/dpotrs.f +++ b/SRC/dpotrs.f @@ -1,6 +1,6 @@ SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dppcon.f b/SRC/dppcon.f index c90b38b3..f7ac0adf 100644 --- a/SRC/dppcon.f +++ b/SRC/dppcon.f @@ -1,6 +1,6 @@ SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dppequ.f b/SRC/dppequ.f index 814b1136..3c37c3be 100644 --- a/SRC/dppequ.f +++ b/SRC/dppequ.f @@ -1,6 +1,6 @@ SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpprfs.f b/SRC/dpprfs.f index 1f2caa87..b5232384 100644 --- a/SRC/dpprfs.f +++ b/SRC/dpprfs.f @@ -1,7 +1,7 @@ SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dppsv.f b/SRC/dppsv.f index 87199324..635bb2ca 100644 --- a/SRC/dppsv.f +++ b/SRC/dppsv.f @@ -1,6 +1,6 @@ SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dppsvx.f b/SRC/dppsvx.f index 00c33b6b..d0c71f0e 100644 --- a/SRC/dppsvx.f +++ b/SRC/dppsvx.f @@ -1,7 +1,7 @@ SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpptrf.f b/SRC/dpptrf.f index a5e2a596..27eaeebc 100644 --- a/SRC/dpptrf.f +++ b/SRC/dpptrf.f @@ -1,6 +1,6 @@ SUBROUTINE DPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpptri.f b/SRC/dpptri.f index 78596083..06f76e36 100644 --- a/SRC/dpptri.f +++ b/SRC/dpptri.f @@ -1,6 +1,6 @@ SUBROUTINE DPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpptrs.f b/SRC/dpptrs.f index 876b9ef4..64cb2840 100644 --- a/SRC/dpptrs.f +++ b/SRC/dpptrs.f @@ -1,6 +1,6 @@ SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpstf2.f b/SRC/dpstf2.f new file mode 100644 index 00000000..91cc3b30 --- /dev/null +++ b/SRC/dpstf2.f @@ -0,0 +1,308 @@ + SUBROUTINE DPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK PROTOTYPE routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* DPSTF2 computes the Cholesky factorization with complete +* pivoting of a real symmetric positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 2 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) DOUBLE PRECISION +* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK DOUBLE PRECISION array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AJJ, DSTOP, DTEMP + INTEGER I, ITEMP, J, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME, DISNAN + EXTERNAL DLAMCH, LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT, MAXLOC +* .. +* .. 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( 'DPSTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + PVT = 1 + AJJ = A( PVT, PVT ) + DO I = 2, N + IF( A( I, I ).GT.AJJ ) THEN + PVT = I + AJJ = A( PVT, PVT ) + END IF + END DO + IF( AJJ.EQ.ZERO.OR.DISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 170 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ + ELSE + DSTOP = TOL + END IF +* +* Set first half of WORK to zero, holds dot products +* + DO 110 I = 1, N + WORK( I ) = 0 + 110 CONTINUE +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 130 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 120 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + A( J-1, I )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 120 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 160 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL DSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL DSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + CALL DSWAP( PVT-J-1, A( J, J+1 ), LDA, A( J+1, PVT ), 1 ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J +* + IF( J.LT.N ) THEN + CALL DGEMV( 'Trans', J-1, N-J, -ONE, A( 1, J+1 ), LDA, + $ A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) + CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 130 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 150 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 140 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + A( I, J-1 )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 140 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 160 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL DSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL DSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1, PVT ), + $ 1 ) + CALL DSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), LDA ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J +* + IF( J.LT.N ) THEN + CALL DGEMV( 'No Trans', N-J, J-1, -ONE, A( J+1, 1 ), LDA, + $ A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) + CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 150 CONTINUE +* + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 170 + 160 CONTINUE +* +* Rank is number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 170 CONTINUE + RETURN +* +* End of DPSTF2 +* + END diff --git a/SRC/dpstrf.f b/SRC/dpstrf.f new file mode 100644 index 00000000..14e982a2 --- /dev/null +++ b/SRC/dpstrf.f @@ -0,0 +1,366 @@ + SUBROUTINE DPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* DPSTRF computes the Cholesky factorization with complete +* pivoting of a real symmetric positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 3 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) DOUBLE PRECISION +* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK DOUBLE PRECISION array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AJJ, DSTOP, DTEMP + INTEGER I, ITEMP, J, JB, K, NB, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + LOGICAL LSAME, DISNAN + EXTERNAL DLAMCH, ILAENV, LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DPSTF2, DSCAL, DSWAP, DSYRK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, MAXLOC +* .. +* .. 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( 'DPSTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get block size +* + NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL DPSTF2( UPLO, N, A( 1, 1 ), LDA, PIV, RANK, TOL, WORK, + $ INFO ) + GO TO 200 +* + ELSE +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + PVT = 1 + AJJ = A( PVT, PVT ) + DO I = 2, N + IF( A( I, I ).GT.AJJ ) THEN + PVT = I + AJJ = A( PVT, PVT ) + END IF + END DO + IF( AJJ.EQ.ZERO.OR.DISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 200 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ + ELSE + DSTOP = TOL + END IF +* +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 140 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 110 I = K, N + WORK( I ) = 0 + 110 CONTINUE +* + DO 130 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 120 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + A( J-1, I )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 120 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL DSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL DSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + CALL DSWAP( PVT-J-1, A( J, J+1 ), LDA, + $ A( J+1, PVT ), 1 ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL DGEMV( 'Trans', J-K, N-J, -ONE, A( K, J+1 ), + $ LDA, A( K, J ), 1, ONE, A( J, J+1 ), + $ LDA ) + CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 130 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL DSYRK( 'Upper', 'Trans', N-J+1, JB, -ONE, + $ A( K, J ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 140 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 180 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 150 I = K, N + WORK( I ) = 0 + 150 CONTINUE +* + DO 170 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 160 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + A( I, J-1 )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 160 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL DSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL DSWAP( N-PVT, A( PVT+1, J ), 1, + $ A( PVT+1, PVT ), 1 ) + CALL DSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), + $ LDA ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL DGEMV( 'No Trans', N-J, J-K, -ONE, + $ A( J+1, K ), LDA, A( J, K ), LDA, ONE, + $ A( J+1, J ), 1 ) + CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 170 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL DSYRK( 'Lower', 'No Trans', N-J+1, JB, -ONE, + $ A( J, K ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 180 CONTINUE +* + END IF + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 200 + 190 CONTINUE +* +* Rank is the number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 200 CONTINUE + RETURN +* +* End of DPSTRF +* + END diff --git a/SRC/dptcon.f b/SRC/dptcon.f index e340c13d..a6d640ec 100644 --- a/SRC/dptcon.f +++ b/SRC/dptcon.f @@ -1,6 +1,6 @@ SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpteqr.f b/SRC/dpteqr.f index a00c7c76..308cedb0 100644 --- a/SRC/dpteqr.f +++ b/SRC/dpteqr.f @@ -1,6 +1,6 @@ SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dptrfs.f b/SRC/dptrfs.f index 41bd0058..99f882b8 100644 --- a/SRC/dptrfs.f +++ b/SRC/dptrfs.f @@ -1,7 +1,7 @@ SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, $ BERR, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dptsv.f b/SRC/dptsv.f index dd5f0bed..f67c9959 100644 --- a/SRC/dptsv.f +++ b/SRC/dptsv.f @@ -1,6 +1,6 @@ SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dptsvx.f b/SRC/dptsvx.f index 4824b355..2d649f2b 100644 --- a/SRC/dptsvx.f +++ b/SRC/dptsvx.f @@ -1,7 +1,7 @@ SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpttrf.f b/SRC/dpttrf.f index 7f774ee1..29de1a1e 100644 --- a/SRC/dpttrf.f +++ b/SRC/dpttrf.f @@ -1,6 +1,6 @@ SUBROUTINE DPTTRF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dpttrs.f b/SRC/dpttrs.f index 9a2a4771..31dd0566 100644 --- a/SRC/dpttrs.f +++ b/SRC/dpttrs.f @@ -1,6 +1,6 @@ SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dptts2.f b/SRC/dptts2.f index ce2337d0..5e4ad7a9 100644 --- a/SRC/dptts2.f +++ b/SRC/dptts2.f @@ -1,6 +1,6 @@ SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/drscl.f b/SRC/drscl.f index a13e96d8..23c9e7be 100644 --- a/SRC/drscl.f +++ b/SRC/drscl.f @@ -1,6 +1,6 @@ SUBROUTINE DRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbev.f b/SRC/dsbev.f index cfe524e4..e48c0882 100644 --- a/SRC/dsbev.f +++ b/SRC/dsbev.f @@ -1,7 +1,7 @@ SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbevd.f b/SRC/dsbevd.f index 73adab72..f51f77b0 100644 --- a/SRC/dsbevd.f +++ b/SRC/dsbevd.f @@ -1,7 +1,7 @@ SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbevx.f b/SRC/dsbevx.f index 18b7d935..6dca6773 100644 --- a/SRC/dsbevx.f +++ b/SRC/dsbevx.f @@ -2,7 +2,7 @@ $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbgst.f b/SRC/dsbgst.f index a8ea6210..f16d3e75 100644 --- a/SRC/dsbgst.f +++ b/SRC/dsbgst.f @@ -1,7 +1,7 @@ SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbgv.f b/SRC/dsbgv.f index b3a56435..62246ef9 100644 --- a/SRC/dsbgv.f +++ b/SRC/dsbgv.f @@ -1,7 +1,7 @@ SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbgvd.f b/SRC/dsbgvd.f index 36b4f50d..874c33fc 100644 --- a/SRC/dsbgvd.f +++ b/SRC/dsbgvd.f @@ -1,7 +1,7 @@ SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbgvx.f b/SRC/dsbgvx.f index ac65458b..9e05a19d 100644 --- a/SRC/dsbgvx.f +++ b/SRC/dsbgvx.f @@ -2,7 +2,7 @@ $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsbtrd.f b/SRC/dsbtrd.f index 788b8fa7..a735afe2 100644 --- a/SRC/dsbtrd.f +++ b/SRC/dsbtrd.f @@ -1,7 +1,7 @@ SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsfrk.f b/SRC/dsfrk.f new file mode 100644 index 00000000..30f82015 --- /dev/null +++ b/SRC/dsfrk.f @@ -0,0 +1,470 @@ + SUBROUTINE DSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, + + C ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER K, LDA, N + CHARACTER TRANS, TRANSR, UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for C in RFP Format. +* +* DSFRK performs one of the symmetric rank--k operations +* +* C := alpha*A*A' + beta*C, +* +* or +* +* C := alpha*A'*A + beta*C, +* +* where alpha and beta are real scalars, C is an n--by--n symmetric +* matrix and A is an n--by--k matrix in the first case and a k--by--n +* matrix in the second case. +* +* Arguments +* ========== +* +* TRANSR (input) CHARACTER +* = 'N': The Normal Form of RFP A is stored; +* = 'T': The Transpose Form of RFP A is stored. +* +* UPLO - (input) CHARACTER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array C is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of C +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of C +* is to be referenced. +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. +* +* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. +* +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the order of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - (input) INTEGER. +* On entry with TRANS = 'N' or 'n', K specifies the number +* of columns of the matrix A, and on entry with TRANS = 'T' +* or 't', K specifies the number of rows of the matrix A. K +* must be at least zero. +* Unchanged on exit. +* +* ALPHA - (input) DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - (input) DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where KA +* is K when TRANS = 'N' or 'n', and is N otherwise. Before +* entry with TRANS = 'N' or 'n', the leading N--by--K part of +* the array A must contain the matrix A, otherwise the leading +* K--by--N part of the array A must contain the matrix A. +* Unchanged on exit. +* +* LDA - (input) INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDA must be at least max( 1, n ), otherwise LDA must +* be at least max( 1, k ). +* Unchanged on exit. +* +* BETA - (input) DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. +* Unchanged on exit. +* +* +* C - (input/output) DOUBLE PRECISION array, dimension ( NT ); +* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP +* Format. RFP Format is described by TRANSR, UPLO and N. +* +* Arguments +* ========== +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS + INTEGER INFO, NROWA, J, NK, N1, N2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGEMM, DSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) +* + IF( NOTRANS ) THEN + NROWA = N + ELSE + NROWA = K + END IF +* + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSFRK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* +* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not +* done (it is in DSYRK for example) and left in the general case. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + + ( BETA.EQ.ONE ) ) )RETURN +* + IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN + DO J = 1, ( ( N*( N+1 ) ) / 2 ) + C( J ) = ZERO + END DO + RETURN + END IF +* +* C is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and NK. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + NK = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL DSYRK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N+1 ), N ) + CALL DGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL DSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N+1 ), N ) + CALL DGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL DSYRK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, + + BETA, C( N1+1 ), N ) + CALL DGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( N2, 1 ), LDA, BETA, C( 1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL DSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N2 ), LDA, + + BETA, C( N1+1 ), N ) + CALL DGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, N2 ), LDA, BETA, C( 1 ), N ) +* + END IF +* + END IF +* + ELSE +* +* N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL DSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL DGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( N1+1, 1 ), LDA, BETA, + + C( N1*N1+1 ), N1 ) +* + ELSE +* +* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL DSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL DGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, N1+1 ), LDA, BETA, + + C( N1*N1+1 ), N1 ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL DSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL DGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) +* + ELSE +* +* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL DSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL DGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), + + N+1 ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, BETA, C( 1 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, BETA, C( 1 ), + + N+1 ) +* + END IF +* + END IF +* + ELSE +* +* N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), NK ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, BETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), NK ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, BETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' +* + CALL DSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL DSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL DGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' +* + CALL DSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL DSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL DGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) +* + END IF +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DSFRK +* + END diff --git a/SRC/dsgesv.f b/SRC/dsgesv.f index 5be14625..1bf5a8df 100644 --- a/SRC/dsgesv.f +++ b/SRC/dsgesv.f @@ -1,24 +1,19 @@ SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, - + SWORK, ITER, INFO) + + SWORK, ITER, INFO ) * -* -- LAPACK PROTOTYPE driver routine (version 3.1.1) -- +* -- LAPACK PROTOTYPE driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * February 2007 * * .. -* .. WARNING: PROTOTYPE .. -* This is an LAPACK PROTOTYPE routine which means that the -* interface of this routine is likely to be changed in the future -* based on community feedback. -* -* .. * .. Scalar Arguments .. - INTEGER INFO,ITER,LDA,LDB,LDX,N,NRHS + INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS * .. * .. Array Arguments .. - INTEGER IPIV(*) - REAL SWORK(*) - DOUBLE PRECISION A(LDA,*),B(LDB,*),WORK(N,*),X(LDX,*) + INTEGER IPIV( * ) + REAL SWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), + + X( LDX, * ) * .. * * Purpose @@ -28,22 +23,23 @@ * A * X = B, * where A is an N-by-N matrix and X and B are N-by-NRHS matrices. * -* DSGESV first attempts to factorize the matrix in SINGLE PRECISION -* and use this factorization within an iterative refinement procedure to -* produce a solution with DOUBLE PRECISION normwise backward error +* DSGESV first attempts to factorize the matrix in SINGLE PRECISION +* and use this factorization within an iterative refinement procedure +* to produce a solution with DOUBLE PRECISION normwise backward error * quality (see below). If the approach fails the method switches to a * DOUBLE PRECISION factorization and solve. * * The iterative refinement is not going to be a winning strategy if -* the ratio SINGLE PRECISION performance over DOUBLE PRECISION performance -* is too small. A reasonable strategy should take the number of right-hand -* sides and the size of the matrix into account. This might be done with a -* call to ILAENV in the future. Up to now, we always try iterative refinement. +* the ratio SINGLE PRECISION performance over DOUBLE PRECISION +* performance is too small. A reasonable strategy should take the +* number of right-hand sides and the size of the matrix into account. +* This might be done with a call to ILAENV in the future. Up to now, we +* always try iterative refinement. * * The iterative refinement process is stopped if * ITER > ITERMAX * or for all the RHS we have: -* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX +* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX * where * o ITER is the number of the current iteration in the iterative * refinement process @@ -51,7 +47,8 @@ * o XNRM is the infinity-norm of the solution * o ANRM is the infinity-operator-norm of the matrix A * o EPS is the machine epsilon returned by DLAMCH('Epsilon') -* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively. +* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 +* respectively. * * Arguments * ========= @@ -80,12 +77,12 @@ * IPIV (output) INTEGER array, dimension (N) * The pivot indices that define the permutation matrix P; * row i of the matrix was interchanged with row IPIV(i). -* Corresponds either to the single precision factorization -* (if INFO.EQ.0 and ITER.GE.0) or the double precision +* Corresponds either to the single precision factorization +* (if INFO.EQ.0 and ITER.GE.0) or the double precision * factorization (if INFO.EQ.0 and ITER.LT.0). * * B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) -* The N-by-NRHS matrix of right hand side matrix B. +* The N-by-NRHS right hand side matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). @@ -100,16 +97,16 @@ * This array is used to hold the residual vectors. * * SWORK (workspace) REAL array, dimension (N*(N+NRHS)) -* This array is used to use the single precision matrix and the +* This array is used to use the single precision matrix and the * right-hand sides or solutions in single precision. * * ITER (output) INTEGER * < 0: iterative refinement has failed, double precision * factorization has been performed -* -1 : taking into account machine parameters, N, NRHS, it -* is a priori not worth working in SINGLE PRECISION -* -2 : overflow of an entry when moving from double to -* SINGLE PRECISION +* -1 : the routine fell back to full precision for +* implementation- or machine-specific reasons +* -2 : narrowing the precision induced an overflow, +* the routine fell back to full precision * -3 : failure of SGETRF * -31: stop the iterative refinement after the 30th * iterations @@ -127,73 +124,77 @@ * ========= * * .. Parameters .. - DOUBLE PRECISION NEGONE,ONE - PARAMETER (NEGONE=-1.0D+0,ONE=1.0D+0) + LOGICAL DOITREF + PARAMETER ( DOITREF = .TRUE. ) +* + INTEGER ITERMAX + PARAMETER ( ITERMAX = 30 ) +* + DOUBLE PRECISION BWDMAX + PARAMETER ( BWDMAX = 1.0E+00 ) +* + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D+0, ONE = 1.0D+0 ) * * .. Local Scalars .. - LOGICAL DOITREF - INTEGER I,IITER,ITERMAX,OK,PTSA,PTSX - DOUBLE PRECISION ANRM,BWDMAX,CTE,EPS,RNRM,XNRM + INTEGER I, IITER, PTSA, PTSX + DOUBLE PRECISION ANRM, CTE, EPS, RNRM, XNRM * * .. External Subroutines .. - EXTERNAL DAXPY,DGEMM,DLACPY,DLAG2S,SLAG2D, - + SGETRF,SGETRS,XERBLA + EXTERNAL DAXPY, DGEMM, DLACPY, DLAG2S, SLAG2D, SGETRF, + + SGETRS, XERBLA * .. * .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH,DLANGE - EXTERNAL IDAMAX,DLAMCH,DLANGE + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANGE + EXTERNAL IDAMAX, DLAMCH, DLANGE * .. * .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,MAX,SQRT + INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Executable Statements .. * - ITERMAX = 30 - BWDMAX = 1.0E+00 - DOITREF = .TRUE. -* - OK = 0 INFO = 0 ITER = 0 * * Test the input parameters. * - IF (N.LT.0) THEN - INFO = -1 - ELSE IF (NRHS.LT.0) THEN - INFO = -2 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = -4 - ELSE IF (LDB.LT.MAX(1,N)) THEN - INFO = -7 - ELSE IF (LDX.LT.MAX(1,N)) THEN - INFO = -9 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 END IF - IF (INFO.NE.0) THEN - CALL XERBLA('DSGESV',-INFO) - RETURN + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSGESV', -INFO ) + RETURN END IF * * Quick return if (N.EQ.0). * - IF (N.EQ.0) RETURN + IF( N.EQ.0 ) + + RETURN * * Skip single precision iterative refinement if a priori slower * than double precision factorization. * - IF (.NOT.DOITREF) THEN - ITER = -1 - GO TO 40 + IF( .NOT.DOITREF ) THEN + ITER = -1 + GO TO 40 END IF * * Compute some constants. * - ANRM = DLANGE('I',N,N,A,LDA,WORK) - EPS = DLAMCH('Epsilon') - CTE = ANRM*EPS*SQRT(DBLE(N))*BWDMAX + ANRM = DLANGE( 'I', N, N, A, LDA, WORK ) + EPS = DLAMCH( 'Epsilon' ) + CTE = ANRM*EPS*SQRT( DBLE( N ) )*BWDMAX * -* Set the pointers PTSA, PTSX for referencing SA and SX in SWORK. +* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. * PTSA = 1 PTSX = PTSA + N*N @@ -201,120 +202,124 @@ * Convert B from double precision to single precision and store the * result in SX. * - CALL DLAG2S(N,NRHS,B,LDB,SWORK(PTSX),N,INFO) + CALL DLAG2S( N, NRHS, B, LDB, SWORK( PTSX ), N, INFO ) * - IF (INFO.NE.0) THEN - ITER = -2 - GO TO 40 + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 END IF * * Convert A from double precision to single precision and store the * result in SA. * - CALL DLAG2S(N,N,A,LDA,SWORK(PTSA),N,INFO) + CALL DLAG2S( N, N, A, LDA, SWORK( PTSA ), N, INFO ) * - IF (INFO.NE.0) THEN - ITER = -2 - GO TO 40 + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 END IF * * Compute the LU factorization of SA. * - CALL SGETRF(N,N,SWORK(PTSA),N,IPIV,INFO) + CALL SGETRF( N, N, SWORK( PTSA ), N, IPIV, INFO ) * - IF (INFO.NE.0) THEN - ITER = -3 - GO TO 40 + IF( INFO.NE.0 ) THEN + ITER = -3 + GO TO 40 END IF * * Solve the system SA*SX = SB. * - CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV, - + SWORK(PTSX),N,INFO) + CALL SGETRS( 'No transpose', N, NRHS, SWORK( PTSA ), N, IPIV, + + SWORK( PTSX ), N, INFO ) * * Convert SX back to double precision * - CALL SLAG2D(N,NRHS,SWORK(PTSX),N,X,LDX,INFO) + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, X, LDX, INFO ) * * Compute R = B - AX (R is WORK). * - CALL DLACPY('All',N,NRHS,B,LDB,WORK,N) + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) * - CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,LDA,X, - + LDX,ONE,WORK,N) + CALL DGEMM( 'No Transpose', 'No Transpose', N, NRHS, N, NEGONE, A, + + LDA, X, LDX, ONE, WORK, N ) * -* Check whether the NRHS normwised backward errors satisfy the +* Check whether the NRHS normwise backward errors satisfy the * stopping criterion. If yes, set ITER=0 and return. * - DO I = 1,NRHS - XNRM = ABS(X(IDAMAX(N,X(1,I),1),I)) - RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I)) - IF (RNRM.GT.XNRM*CTE) GOTO 10 + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 10 END DO * -* If we are here, the NRHS normwised backward errors satisfy the +* If we are here, the NRHS normwise backward errors satisfy the * stopping criterion. We are good to exit. * ITER = 0 RETURN * - 10 CONTINUE + 10 CONTINUE * - DO 30 IITER = 1,ITERMAX + DO 30 IITER = 1, ITERMAX * -* Convert R (in WORK) from double precision to single precision -* and store the result in SX. +* Convert R (in WORK) from double precision to single precision +* and store the result in SX. * - CALL DLAG2S(N,NRHS,WORK,N,SWORK(PTSX),N,INFO) + CALL DLAG2S( N, NRHS, WORK, N, SWORK( PTSX ), N, INFO ) * - IF (INFO.NE.0) THEN - ITER = -2 - GO TO 40 - END IF + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF * -* Solve the system SA*SX = SR. +* Solve the system SA*SX = SR. * - CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV, - + SWORK(PTSX),N,INFO) + CALL SGETRS( 'No transpose', N, NRHS, SWORK( PTSA ), N, IPIV, + + SWORK( PTSX ), N, INFO ) * -* Convert SX back to double precision and update the current -* iterate. +* Convert SX back to double precision and update the current +* iterate. * - CALL SLAG2D(N,NRHS,SWORK(PTSX),N,WORK,N,INFO) + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, WORK, N, INFO ) * - CALL DAXPY(N*NRHS,ONE,WORK,1,X,1) + DO I = 1, NRHS + CALL DAXPY( N, ONE, WORK( 1, I ), 1, X( 1, I ), 1 ) + END DO * -* Compute R = B - AX (R is WORK). +* Compute R = B - AX (R is WORK). * - CALL DLACPY('All',N,NRHS,B,LDB,WORK,N) + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) * - CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A, - + LDA,X,LDX,ONE,WORK,N) + CALL DGEMM( 'No Transpose', 'No Transpose', N, NRHS, N, NEGONE, + + A, LDA, X, LDX, ONE, WORK, N ) * -* Check whether the NRHS normwised backward errors satisfy the -* stopping criterion. If yes, set ITER=IITER>0 and return. +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=IITER>0 and return. * - DO I = 1,NRHS - XNRM = ABS(X(IDAMAX(N,X(1,I),1),I)) - RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I)) - IF (RNRM.GT.XNRM*CTE) GOTO 20 - END DO + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 20 + END DO * -* If we are here, the NRHS normwised backward errors satisfy the -* stopping criterion, we are good to exit. +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion, we are good to exit. * - ITER = IITER + ITER = IITER * - RETURN + RETURN * - 20 CONTINUE + 20 CONTINUE * 30 CONTINUE * * If we are at this place of the code, this is because we have -* performed ITER=ITERMAX iterations and never satisified the stopping -* criterion, set up the ITER flag accordingly and follow up on double -* precision routine. +* performed ITER=ITERMAX iterations and never satisified the +* stopping criterion, set up the ITER flag accordingly and follow up +* on double precision routine. * ITER = -ITERMAX - 1 * @@ -323,13 +328,14 @@ * Single-precision iterative refinement failed to converge to a * satisfactory solution, so we resort to double precision. * - CALL DGETRF(N,N,A,LDA,IPIV,INFO) + CALL DGETRF( N, N, A, LDA, IPIV, INFO ) * - CALL DLACPY('All',N,NRHS,B,LDB,X,LDX) + IF( INFO.NE.0 ) + + RETURN * - IF (INFO.EQ.0) THEN - CALL DGETRS('No transpose',N,NRHS,A,LDA,IPIV,X,LDX,INFO) - END IF + CALL DLACPY( 'All', N, NRHS, B, LDB, X, LDX ) + CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, X, LDX, + + INFO ) * RETURN * diff --git a/SRC/dspcon.f b/SRC/dspcon.f index 3e695d0e..7b18c74b 100644 --- a/SRC/dspcon.f +++ b/SRC/dspcon.f @@ -1,7 +1,7 @@ SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspev.f b/SRC/dspev.f index 64582c99..8a59bba2 100644 --- a/SRC/dspev.f +++ b/SRC/dspev.f @@ -1,6 +1,6 @@ SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspevd.f b/SRC/dspevd.f index 3dd4efab..bca62b0e 100644 --- a/SRC/dspevd.f +++ b/SRC/dspevd.f @@ -1,7 +1,7 @@ SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspevx.f b/SRC/dspevx.f index 68611699..b2cc5047 100644 --- a/SRC/dspevx.f +++ b/SRC/dspevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -329,7 +329,7 @@ * form to eigenvectors returned by DSTEIN. * CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), INFO ) + $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. diff --git a/SRC/dspgst.f b/SRC/dspgst.f index 8e121a94..1aebc299 100644 --- a/SRC/dspgst.f +++ b/SRC/dspgst.f @@ -1,6 +1,6 @@ SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspgv.f b/SRC/dspgv.f index 737a1ee3..f074a1e9 100644 --- a/SRC/dspgv.f +++ b/SRC/dspgv.f @@ -1,7 +1,7 @@ SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspgvd.f b/SRC/dspgvd.f index 23850cf7..f3f6eace 100644 --- a/SRC/dspgvd.f +++ b/SRC/dspgvd.f @@ -1,7 +1,7 @@ SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspgvx.f b/SRC/dspgvx.f index de44ee90..da9d7da4 100644 --- a/SRC/dspgvx.f +++ b/SRC/dspgvx.f @@ -2,7 +2,7 @@ $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsposv.f b/SRC/dsposv.f new file mode 100644 index 00000000..06f9aee2 --- /dev/null +++ b/SRC/dsposv.f @@ -0,0 +1,351 @@ + SUBROUTINE DSPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, + + SWORK, ITER, INFO ) +* +* -- LAPACK PROTOTYPE driver routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* May 2007 +* +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + REAL SWORK( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( N, * ), + + X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DSPOSV computes the solution to a real system of linear equations +* A * X = B, +* where A is an N-by-N symmetric positive definite matrix and X and B +* are N-by-NRHS matrices. +* +* DSPOSV first attempts to factorize the matrix in SINGLE PRECISION +* and use this factorization within an iterative refinement procedure +* to produce a solution with DOUBLE PRECISION normwise backward error +* quality (see below). If the approach fails the method switches to a +* DOUBLE PRECISION factorization and solve. +* +* The iterative refinement is not going to be a winning strategy if +* the ratio SINGLE PRECISION performance over DOUBLE PRECISION +* performance is too small. A reasonable strategy should take the +* number of right-hand sides and the size of the matrix into account. +* This might be done with a call to ILAENV in the future. Up to now, we +* always try iterative refinement. +* +* The iterative refinement process is stopped if +* ITER > ITERMAX +* or for all the RHS we have: +* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX +* where +* o ITER is the number of the current iteration in the iterative +* refinement process +* o RNRM is the infinity-norm of the residual +* o XNRM is the infinity-norm of the solution +* o ANRM is the infinity-operator-norm of the matrix A +* o EPS is the machine epsilon returned by DLAMCH('Epsilon') +* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 +* respectively. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input or input/ouptut) DOUBLE PRECISION array, +* dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit, if iterative refinement has been successfully used +* (INFO.EQ.0 and ITER.GE.0, see description below), then A is +* unchanged, if double precision factorization has been used +* (INFO.EQ.0 and ITER.LT.0, see description below), then the +* array A contains the factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T. +* +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) +* The N-by-NRHS right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS) +* This array is used to hold the residual vectors. +* +* SWORK (workspace) REAL array, dimension (N*(N+NRHS)) +* This array is used to use the single precision matrix and the +* right-hand sides or solutions in single precision. +* +* ITER (output) INTEGER +* < 0: iterative refinement has failed, double precision +* factorization has been performed +* -1 : the routine fell back to full precision for +* implementation- or machine-specific reasons +* -2 : narrowing the precision induced an overflow, +* the routine fell back to full precision +* -3 : failure of SPOTRF +* -31: stop the iterative refinement after the 30th +* iterations +* > 0: iterative refinement has been sucessfully used. +* Returns the number of iterations +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i of (DOUBLE +* PRECISION) A is not positive definite, so the +* factorization could not be completed, and the solution +* has not been computed. +* +* ========= +* +* .. Parameters .. + LOGICAL DOITREF + PARAMETER ( DOITREF = .TRUE. ) +* + INTEGER ITERMAX + PARAMETER ( ITERMAX = 30 ) +* + DOUBLE PRECISION BWDMAX + PARAMETER ( BWDMAX = 1.0E+00 ) +* + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D+0, ONE = 1.0D+0 ) +* +* .. Local Scalars .. + INTEGER I, IITER, PTSA, PTSX + DOUBLE PRECISION ANRM, CTE, EPS, RNRM, XNRM +* +* .. External Subroutines .. + EXTERNAL DAXPY, DSYMM, DLACPY, DLAT2S, DLAG2S, SLAG2D, + + SPOTRF, SPOTRS, XERBLA +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANSY + LOGICAL LSAME + EXTERNAL IDAMAX, DLAMCH, DLANSY, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + ITER = 0 +* +* Test the input parameters. +* + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPOSV', -INFO ) + RETURN + END IF +* +* Quick return if (N.EQ.0). +* + IF( N.EQ.0 ) + + RETURN +* +* Skip single precision iterative refinement if a priori slower +* than double precision factorization. +* + IF( .NOT.DOITREF ) THEN + ITER = -1 + GO TO 40 + END IF +* +* Compute some constants. +* + ANRM = DLANSY( 'I', UPLO, N, A, LDA, WORK ) + EPS = DLAMCH( 'Epsilon' ) + CTE = ANRM*EPS*SQRT( DBLE( N ) )*BWDMAX +* +* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. +* + PTSA = 1 + PTSX = PTSA + N*N +* +* Convert B from double precision to single precision and store the +* result in SX. +* + CALL DLAG2S( N, NRHS, B, LDB, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Convert A from double precision to single precision and store the +* result in SA. +* + CALL DLAT2S( UPLO, N, A, LDA, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Compute the Cholesky factorization of SA. +* + CALL SPOTRF( UPLO, N, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -3 + GO TO 40 + END IF +* +* Solve the system SA*SX = SB. +* + CALL SPOTRS( UPLO, N, NRHS, SWORK( PTSA ), N, SWORK( PTSX ), N, + + INFO ) +* +* Convert SX back to double precision +* + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, X, LDX, INFO ) +* +* Compute R = B - AX (R is WORK). +* + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL DSYMM( 'Left', UPLO, N, NRHS, NEGONE, A, LDA, X, LDX, ONE, + + WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=0 and return. +* + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 10 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion. We are good to exit. +* + ITER = 0 + RETURN +* + 10 CONTINUE +* + DO 30 IITER = 1, ITERMAX +* +* Convert R (in WORK) from double precision to single precision +* and store the result in SX. +* + CALL DLAG2S( N, NRHS, WORK, N, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Solve the system SA*SX = SR. +* + CALL SPOTRS( UPLO, N, NRHS, SWORK( PTSA ), N, SWORK( PTSX ), N, + + INFO ) +* +* Convert SX back to double precision and update the current +* iterate. +* + CALL SLAG2D( N, NRHS, SWORK( PTSX ), N, WORK, N, INFO ) +* + DO I = 1, NRHS + CALL DAXPY( N, ONE, WORK( 1, I ), 1, X( 1, I ), 1 ) + END DO +* +* Compute R = B - AX (R is WORK). +* + CALL DLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL DSYMM( 'L', UPLO, N, NRHS, NEGONE, A, LDA, X, LDX, ONE, + + WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=IITER>0 and return. +* + DO I = 1, NRHS + XNRM = ABS( X( IDAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = ABS( WORK( IDAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 20 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion, we are good to exit. +* + ITER = IITER +* + RETURN +* + 20 CONTINUE +* + 30 CONTINUE +* +* If we are at this place of the code, this is because we have +* performed ITER=ITERMAX iterations and never satisified the +* stopping criterion, set up the ITER flag accordingly and follow +* up on double precision routine. +* + ITER = -ITERMAX - 1 +* + 40 CONTINUE +* +* Single-precision iterative refinement failed to converge to a +* satisfactory solution, so we resort to double precision. +* + CALL DPOTRF( UPLO, N, A, LDA, INFO ) +* + IF( INFO.NE.0 ) + + RETURN +* + CALL DLACPY( 'All', N, NRHS, B, LDB, X, LDX ) + CALL DPOTRS( UPLO, N, NRHS, A, LDA, X, LDX, INFO ) +* + RETURN +* +* End of DSPOSV. +* + END diff --git a/SRC/dsprfs.f b/SRC/dsprfs.f index 265c2bdd..0814eca4 100644 --- a/SRC/dsprfs.f +++ b/SRC/dsprfs.f @@ -1,7 +1,7 @@ SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspsv.f b/SRC/dspsv.f index 16de3057..42d975d1 100644 --- a/SRC/dspsv.f +++ b/SRC/dspsv.f @@ -1,6 +1,6 @@ SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dspsvx.f b/SRC/dspsvx.f index 46218269..fcc64971 100644 --- a/SRC/dspsvx.f +++ b/SRC/dspsvx.f @@ -1,7 +1,7 @@ SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsptrd.f b/SRC/dsptrd.f index 6d3390e3..f060dbcd 100644 --- a/SRC/dsptrd.f +++ b/SRC/dsptrd.f @@ -1,6 +1,6 @@ SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsptrf.f b/SRC/dsptrf.f index 8b8a9185..2b97ce2d 100644 --- a/SRC/dsptrf.f +++ b/SRC/dsptrf.f @@ -1,6 +1,6 @@ SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsptri.f b/SRC/dsptri.f index 406352cd..b8e406d6 100644 --- a/SRC/dsptri.f +++ b/SRC/dsptri.f @@ -1,6 +1,6 @@ SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsptrs.f b/SRC/dsptrs.f index 9f03f797..bc7ff108 100644 --- a/SRC/dsptrs.f +++ b/SRC/dsptrs.f @@ -1,6 +1,6 @@ SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstebz.f b/SRC/dstebz.f index b540715b..900880e1 100644 --- a/SRC/dstebz.f +++ b/SRC/dstebz.f @@ -2,7 +2,7 @@ $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * 8-18-00: Increase FUDGE factor for T3E (eca) diff --git a/SRC/dstedc.f b/SRC/dstedc.f index ad60e029..4256dd9b 100644 --- a/SRC/dstedc.f +++ b/SRC/dstedc.f @@ -1,7 +1,7 @@ SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstegr.f b/SRC/dstegr.f index baecd9b8..404bad6c 100644 --- a/SRC/dstegr.f +++ b/SRC/dstegr.f @@ -5,7 +5,7 @@ IMPLICIT NONE * * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstein.f b/SRC/dstein.f index a39a0f4c..04c50271 100644 --- a/SRC/dstein.f +++ b/SRC/dstein.f @@ -1,7 +1,7 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstemr.f b/SRC/dstemr.f index f459ab71..b8be826e 100644 --- a/SRC/dstemr.f +++ b/SRC/dstemr.f @@ -3,7 +3,7 @@ $ IWORK, LIWORK, INFO ) IMPLICIT NONE * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsteqr.f b/SRC/dsteqr.f index 0afd7957..11650a73 100644 --- a/SRC/dsteqr.f +++ b/SRC/dsteqr.f @@ -1,6 +1,6 @@ SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsterf.f b/SRC/dsterf.f index c17ea23a..3e8b4281 100644 --- a/SRC/dsterf.f +++ b/SRC/dsterf.f @@ -1,6 +1,6 @@ SUBROUTINE DSTERF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstev.f b/SRC/dstev.f index 9c1132f3..f4f2496d 100644 --- a/SRC/dstev.f +++ b/SRC/dstev.f @@ -1,6 +1,6 @@ SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstevd.f b/SRC/dstevd.f index 949ded88..9fe592d4 100644 --- a/SRC/dstevd.f +++ b/SRC/dstevd.f @@ -1,7 +1,7 @@ SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstevr.f b/SRC/dstevr.f index 6a161ebc..fcf72ab7 100644 --- a/SRC/dstevr.f +++ b/SRC/dstevr.f @@ -2,7 +2,7 @@ $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dstevx.f b/SRC/dstevx.f index 8c36122e..fcc8b9d8 100644 --- a/SRC/dstevx.f +++ b/SRC/dstevx.f @@ -1,7 +1,7 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsycon.f b/SRC/dsycon.f index 711b48ca..50f23d7f 100644 --- a/SRC/dsycon.f +++ b/SRC/dsycon.f @@ -1,7 +1,7 @@ SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsyequb.f b/SRC/dsyequb.f new file mode 100644 index 00000000..23d88149 --- /dev/null +++ b/SRC/dsyequb.f @@ -0,0 +1,251 @@ + SUBROUTINE DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), S( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DSYEQUB computes row and column scalings intended to equilibrate a +* symmetric matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The N-by-N symmetric matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) DOUBLE PRECISION +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Executable Statements .. +* +* Test input parameters. +* + INFO = 0 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. 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( 'DSYEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) + S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) + AMAX = MAX( AMAX, ABS( A(I, J) ) ) + END DO + S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) + AMAX = MAX( AMAX, ABS( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) + AMAX = MAX( AMAX, ABS( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) + S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) + AMAX = MAX( AMAX, ABS( A( I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0D+0 / S( J ) + END DO + + TOL = ONE / SQRT(2.0D0 * N) + + DO ITER = 1, MAX_ITER + SCALE = 0.0D+0 + SUMSQ = 0.0D+0 +* BETA = |A|S + DO I = 1, N + WORK(I) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + T = ABS( A( I, J ) ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + DO I = J+1, N + T = ABS( A( I, J ) ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0D+0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0D+0 + DO I = 2*N+1, 3*N + WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG + END DO + CALL DLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = ABS( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 + + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + + END DO + + END DO + + 999 CONTINUE + + SMLNUM = DLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT(AVG) + BASE = DLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) +* + END diff --git a/SRC/dsyev.f b/SRC/dsyev.f index d73600a2..58e4030b 100644 --- a/SRC/dsyev.f +++ b/SRC/dsyev.f @@ -1,6 +1,6 @@ SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsyevd.f b/SRC/dsyevd.f index 4c7ff8dc..9711efe4 100644 --- a/SRC/dsyevd.f +++ b/SRC/dsyevd.f @@ -1,7 +1,7 @@ SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsyevr.f b/SRC/dsyevr.f index c213c998..71c9accd 100644 --- a/SRC/dsyevr.f +++ b/SRC/dsyevr.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsyevx.f b/SRC/dsyevx.f index 8ea48b21..849e6e38 100644 --- a/SRC/dsyevx.f +++ b/SRC/dsyevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsygs2.f b/SRC/dsygs2.f index 2bdc4752..9b12ddd5 100644 --- a/SRC/dsygs2.f +++ b/SRC/dsygs2.f @@ -1,6 +1,6 @@ SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsygst.f b/SRC/dsygst.f index 093c7931..7e0cca39 100644 --- a/SRC/dsygst.f +++ b/SRC/dsygst.f @@ -1,6 +1,6 @@ SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsygv.f b/SRC/dsygv.f index 9ae8b73e..d8f97f34 100644 --- a/SRC/dsygv.f +++ b/SRC/dsygv.f @@ -1,7 +1,7 @@ SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsygvd.f b/SRC/dsygvd.f index 34c50068..3ce19544 100644 --- a/SRC/dsygvd.f +++ b/SRC/dsygvd.f @@ -1,7 +1,7 @@ SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsygvx.f b/SRC/dsygvx.f index e37c1dca..349f6966 100644 --- a/SRC/dsygvx.f +++ b/SRC/dsygvx.f @@ -2,7 +2,7 @@ $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsyrfs.f b/SRC/dsyrfs.f index ee546c63..57883dc4 100644 --- a/SRC/dsyrfs.f +++ b/SRC/dsyrfs.f @@ -1,7 +1,7 @@ SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsyrfsx.f b/SRC/dsyrfsx.f new file mode 100644 index 00000000..9b63c70e --- /dev/null +++ b/SRC/dsyrfsx.f @@ -0,0 +1,573 @@ + SUBROUTINE DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DSYRFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric indefinite, and +* provides error bounds and backward error estimates for the +* solution. In addition to normwise error bound, the code provides +* maximum componentwise error bound if possible. See comments for +* ERR_BNDS_N and ERR_BNDS_C for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) +* The factored form of the matrix A. AF contains the block +* diagonal matrix D and the multipliers used to obtain the +* factor U or L from the factorization A = U*D*U**T or A = +* L*D*L**T as computed by DSYTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by DSYTRF. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 100.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE, N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DSYCON, DLA_SYRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, DLANSY, DLA_SYRCOND + DOUBLE PRECISION DLAMCH, DLANSY, DLA_SYRCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N )*DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = DLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL DLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), WORK( 1 ), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) )*DLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ -1, S, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ 0, S, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF (N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF (ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF (N_ERR_BNDS .GE. LA_LINRX_RCOND_I) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = DLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ 1, X(1,J), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of DSYRFSX +* + END diff --git a/SRC/dsysv.f b/SRC/dsysv.f index add53850..0f117025 100644 --- a/SRC/dsysv.f +++ b/SRC/dsysv.f @@ -1,7 +1,7 @@ SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsysvx.f b/SRC/dsysvx.f index 1a79d1d1..e3596253 100644 --- a/SRC/dsysvx.f +++ b/SRC/dsysvx.f @@ -2,7 +2,7 @@ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsysvxx.f b/SRC/dsysvxx.f new file mode 100644 index 00000000..a9a5e031 --- /dev/null +++ b/SRC/dsysvxx.f @@ -0,0 +1,557 @@ + SUBROUTINE DSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* DSYSVXX uses the diagonal pivoting factorization to compute the +* solution to a double precision system of linear equations A * X = B, where A +* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. DSYSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* DSYSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* DSYSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what DSYSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = U * D * U**T, if UPLO = 'U', or +* A = L * D * L**T, if UPLO = 'L', +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* 3. If some D(i,i)=0, so that D is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is +* less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(R) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T as computed by DSYTRF. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains details of the interchanges and the block +* structure of D, as determined by DSYTRF. If IPIV(k) > 0, +* then rows and columns k and IPIV(k) were interchanged and +* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +* then rows and columns k+1 and -IPIV(k) were interchanged +* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains details of the interchanges and the block +* structure of D, as determined by DSYTRF. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, DLA_SYRPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLA_SYRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL DSYCON, DSYEQUB, DSYTRF, DSYTRS, + $ DLACPY, DLAQSY, XERBLA, DLASCL2, DSYRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in DSYRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DSYRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME(UPLO, 'U') .AND. + $ .NOT.LSAME(UPLO, 'L') ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL DSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL DLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF ( N.GT.0 ) + $ RPVGRW = DLA_SYRPVGRW(UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF ( N.GT.0 ) + $ RPVGRW = DLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) +* +* Compute the solution matrix X. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL DSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL DLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of DSYSVXX +* + END diff --git a/SRC/dsytd2.f b/SRC/dsytd2.f index c696818e..8f1cd712 100644 --- a/SRC/dsytd2.f +++ b/SRC/dsytd2.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsytf2.f b/SRC/dsytf2.f index d5234625..96dfc331 100644 --- a/SRC/dsytf2.f +++ b/SRC/dsytf2.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsytrd.f b/SRC/dsytrd.f index 569ee35b..5ec55ff3 100644 --- a/SRC/dsytrd.f +++ b/SRC/dsytrd.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsytrf.f b/SRC/dsytrf.f index 43a31248..652c1528 100644 --- a/SRC/dsytrf.f +++ b/SRC/dsytrf.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsytri.f b/SRC/dsytri.f index 361de9a3..c42bc63d 100644 --- a/SRC/dsytri.f +++ b/SRC/dsytri.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dsytrs.f b/SRC/dsytrs.f index 163ed5b9..41c71000 100644 --- a/SRC/dsytrs.f +++ b/SRC/dsytrs.f @@ -1,6 +1,6 @@ SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtbcon.f b/SRC/dtbcon.f index 1acdad6c..b26bd363 100644 --- a/SRC/dtbcon.f +++ b/SRC/dtbcon.f @@ -1,7 +1,7 @@ SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtbrfs.f b/SRC/dtbrfs.f index a0023f7c..2845202f 100644 --- a/SRC/dtbrfs.f +++ b/SRC/dtbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtbtrs.f b/SRC/dtbtrs.f index 1dc90b9b..a20448cb 100644 --- a/SRC/dtbtrs.f +++ b/SRC/dtbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtfsm.f b/SRC/dtfsm.f new file mode 100644 index 00000000..93dedb7b --- /dev/null +++ b/SRC/dtfsm.f @@ -0,0 +1,905 @@ + SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, + + B, LDB ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO + INTEGER LDB, M, N + DOUBLE PRECISION ALPHA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for A in RFP Format. +* +* DTFSM solves the matrix equation +* +* op( A )*X = alpha*B or X*op( A ) = alpha*B +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A'. +* +* A is in Rectangular Full Packed (RFP) Format. +* +* The matrix X is overwritten on B. +* +* Arguments +* ========== +* +* TRANSR - (input) CHARACTER +* = 'N': The Normal Form of RFP A is stored; +* = 'T': The Transpose Form of RFP A is stored. +* +* SIDE - (input) CHARACTER +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* Unchanged on exit. +* +* UPLO - (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix +* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER +* On entry, TRANS specifies the form of op( A ) to be used +* in the matrix multiplication as follows: +* +* TRANS = 'N' or 'n' op( A ) = A. +* +* TRANS = 'T' or 't' op( A ) = A'. +* +* Unchanged on exit. +* +* DIAG - (input) CHARACTER +* On entry, DIAG specifies whether or not RFP A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - (input) INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - (input) DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - (input) DOUBLE PRECISION array, dimension (NT); +* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. +* RFP Format is described by TRANSR, UPLO and N as follows: +* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +* TRANSR = 'T' then RFP is the transpose of RFP A as +* defined when TRANSR = 'N'. The contents of RFP A are defined +* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT +* elements of upper packed A either in normal or +* transpose Format. If UPLO = 'L' the RFP A contains +* the NT elements of lower packed A either in normal or +* transpose Format. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is +* even and is N when is odd. +* See the Note below for more details. Unchanged on exit. +* +* B - (input/ouptut) DOUBLE PRECISION array, DIMENSION (LDB,N) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB - (input) INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, + + NOTRANS + INTEGER M1, M2, N1, N2, K, INFO, I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DGEMM, DTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LSIDE = LSAME( SIDE, 'L' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFSM ', -INFO ) + RETURN + END IF +* +* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + + RETURN +* +* Quick return when ALPHA.EQ.(0D+0) +* + IF( ALPHA.EQ.ZERO ) THEN + DO 20 J = 0, N - 1 + DO 10 I = 0, M - 1 + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* + IF( LSIDE ) THEN +* +* SIDE = 'L' +* +* A is M-by-M. +* If M is odd, set NISODD = .TRUE., and M1 and M2. +* If M is even, NISODD = .FALSE., and M. +* + IF( MOD( M, 2 ).EQ.0 ) THEN + MISODD = .FALSE. + K = M / 2 + ELSE + MISODD = .TRUE. + IF( LOWER ) THEN + M2 = M / 2 + M1 = M - M2 + ELSE + M1 = M / 2 + M2 = M - M1 + END IF + END IF +* + IF( MISODD ) THEN +* +* SIDE = 'L' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( 0 ), M, B, LDB ) + CALL DGEMM( 'N', 'N', M2, N, M1, -ONE, A( M1 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, + + A( M ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'T' +* + CALL DTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M ), M, B( M1, 0 ), LDB ) + CALL DGEMM( 'T', 'N', M1, N, M2, -ONE, A( M1 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, + + A( 0 ), M, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( M2 ), M, B, LDB ) + CALL DGEMM( 'T', 'N', M2, N, M1, -ONE, A( 0 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, + + A( M1 ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M1 ), M, B( M1, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M1, N, M2, -ONE, A( 0 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, + + A( M2 ), M, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + + A( 0 ), M1, B, LDB ) + CALL DGEMM( 'T', 'N', M2, N, M1, -ONE, A( M1*M1 ), + + M1, B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, + + A( 1 ), M1, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, + + A( 1 ), M1, B( M1, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M1, N, M2, -ONE, A( M1*M1 ), + + M1, B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, + + A( 0 ), M1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + + A( M2*M2 ), M2, B, LDB ) + CALL DGEMM( 'N', 'N', M2, N, M1, -ONE, A( 0 ), M2, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) + CALL DGEMM( 'T', 'N', M1, N, M2, -ONE, A( 0 ), M2, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, + + A( M2*M2 ), M2, B, LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( 1 ), M+1, B, LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( K+1 ), + + M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ONE, + + A( 0 ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( 0 ), M+1, B( K, 0 ), LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( K+1 ), + + M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ONE, + + A( 1 ), M+1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( K+1 ), M+1, B, LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), M+1, + + B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ONE, + + A( K ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'T' + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( K ), M+1, B( K, 0 ), LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), M+1, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ONE, + + A( K+1 ), M+1, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, + + A( K ), K, B, LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, + + A( K*( K+1 ) ), K, B, LDB, ALPHA, + + B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ONE, + + A( 0 ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, + + A( 0 ), K, B( K, 0 ), LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, + + A( K*( K+1 ) ), K, B( K, 0 ), LDB, + + ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ONE, + + A( K ), K, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, + + A( K*( K+1 ) ), K, B, LDB ) + CALL DGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), K, B, + + LDB, ALPHA, B( K, 0 ), LDB ) + CALL DTRSM( 'L', 'L', 'N', DIAG, K, N, ONE, + + A( K*K ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'T' +* + CALL DTRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, + + A( K*K ), K, B( K, 0 ), LDB ) + CALL DGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), K, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL DTRSM( 'L', 'U', 'N', DIAG, K, N, ONE, + + A( K*( K+1 ) ), K, B, LDB ) +* + END IF +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' +* +* A is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and K. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + K = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* SIDE = 'R' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, + + A( N ), N, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( N1 ), N, ALPHA, B( 0, 0 ), + + LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, + + A( 0 ), N, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, + + A( 0 ), N, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( N1 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, + + A( N ), N, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, + + A( N2 ), N, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( 0 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, + + A( N1 ), N, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, + + A( N1 ), N, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, + + A( N2 ), N, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( 1 ), N1, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), + + LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, + + A( 0 ), N1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( 0 ), N1, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), + + LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, + + A( 1 ), N1, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), + + LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) + CALL DGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), + + LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, + + A( 0 ), N+1, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ONE, + + A( 1 ), N+1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, + + A( 1 ), N+1, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ONE, + + A( 0 ), N+1, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ONE, + + A( K ), N+1, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, + + A( K ), N+1, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ONE, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( 0 ), K, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, 0 ), LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ONE, + + A( K ), K, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( K ), K, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, K ), LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ONE, + + A( 0 ), K, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'N' +* + CALL DTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) + CALL DGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) + CALL DTRSM( 'R', 'L', 'T', DIAG, M, K, ONE, + + A( K*K ), K, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'T' +* + CALL DTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( K*K ), K, B( 0, K ), LDB ) + CALL DGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), + + LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) + CALL DTRSM( 'R', 'U', 'T', DIAG, M, K, ONE, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DTFSM +* + END diff --git a/SRC/dtftri.f b/SRC/dtftri.f new file mode 100644 index 00000000..60eecdd9 --- /dev/null +++ b/SRC/dtftri.f @@ -0,0 +1,407 @@ + SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO, DIAG + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: * ) +* .. +* +* Purpose +* ======= +* +* DTFTRI computes the inverse of a triangular matrix A stored in RFP +* format. +* +* This is a Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* DIAG (input) CHARACTER +* = 'N': A is non-unit triangular; +* = 'U': A is unit triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (0:nt-1); +* nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian +* Positive Definite matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +* the transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A; If UPLO = 'L' the RFP A contains the nt +* elements of lower packed A. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is +* even and N is odd. See the Note below for more details. +* +* On exit, the (triangular) inverse of the original matrix, in +* the same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, A(i,i) is exactly zero. The triangular +* matrix is singular and its inverse can not be computed. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DTRMM, DTRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL DTRTRI( 'L', DIAG, N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'L', 'N', DIAG, N2, N1, -ONE, A( 0 ), + + N, A( N1 ), N ) + CALL DTRTRI( 'U', DIAG, N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'U', 'T', DIAG, N2, N1, ONE, A( N ), N, + + A( N1 ), N ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL DTRTRI( 'L', DIAG, N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'L', 'T', DIAG, N1, N2, -ONE, A( N2 ), + + N, A( 0 ), N ) + CALL DTRTRI( 'U', DIAG, N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'U', 'N', DIAG, N1, N2, ONE, A( N1 ), + + N, A( 0 ), N ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) +* + CALL DTRTRI( 'U', DIAG, N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'U', 'N', DIAG, N1, N2, -ONE, A( 0 ), + + N1, A( N1*N1 ), N1 ) + CALL DTRTRI( 'L', DIAG, N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'L', 'T', DIAG, N1, N2, ONE, A( 1 ), + + N1, A( N1*N1 ), N1 ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) +* + CALL DTRTRI( 'U', DIAG, N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'U', 'T', DIAG, N2, N1, -ONE, + + A( N2*N2 ), N2, A( 0 ), N2 ) + CALL DTRTRI( 'L', DIAG, N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'L', 'N', DIAG, N2, N1, ONE, + + A( N1*N2 ), N2, A( 0 ), N2 ) + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL DTRTRI( 'L', DIAG, K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'L', 'N', DIAG, K, K, -ONE, A( 1 ), + + N+1, A( K+1 ), N+1 ) + CALL DTRTRI( 'U', DIAG, K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'U', 'T', DIAG, K, K, ONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL DTRTRI( 'L', DIAG, K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'L', 'T', DIAG, K, K, -ONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL DTRTRI( 'U', DIAG, K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'U', 'N', DIAG, K, K, ONE, A( K ), N+1, + + A( 0 ), N+1 ) + END IF + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL DTRTRI( 'U', DIAG, K, A( K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'U', 'N', DIAG, K, K, -ONE, A( K ), K, + + A( K*( K+1 ) ), K ) + CALL DTRTRI( 'L', DIAG, K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'L', 'T', DIAG, K, K, ONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL DTRTRI( 'U', DIAG, K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'R', 'U', 'T', DIAG, K, K, -ONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL DTRTRI( 'L', DIAG, K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL DTRMM( 'L', 'L', 'N', DIAG, K, K, ONE, A( K*K ), K, + + A( 0 ), K ) + END IF + END IF + END IF +* + RETURN +* +* End of DTFTRI +* + END diff --git a/SRC/dtfttp.f b/SRC/dtfttp.f new file mode 100644 index 00000000..94064d95 --- /dev/null +++ b/SRC/dtfttp.f @@ -0,0 +1,453 @@ + SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* DTFTTP copies a triangular matrix A from rectangular full packed +* format (TF) to standard packed format (TP). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'T': ARF is in Transpose format; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ARF (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* AP (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFTTP', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + AP( 0 ) = ARF( 0 ) + ELSE + AP( 0 ) = ARF( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTFTTP +* + END diff --git a/SRC/dtfttr.f b/SRC/dtfttr.f new file mode 100644 index 00000000..d1b92dc4 --- /dev/null +++ b/SRC/dtfttr.f @@ -0,0 +1,430 @@ + SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* DTFTTR copies a triangular matrix A from rectangular full packed +* format (TF) to standard full format (TR). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'T': ARF is in Transpose format. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrices ARF and A. N >= 0. +* +* ARF (input) DOUBLE PRECISION array, dimension (N*(N+1)/2). +* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') +* matrix A in RFP format. See the "Notes" below for more +* details. +* +* A (output) DOUBLE PRECISION array, dimension (LDA,N) +* On exit, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT, NX2, NP1X2 + INTEGER I, J, L, IJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTFTTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + A( 0, 0 ) = ARF( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + A( N2+J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + A( J-N1, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + A( I, N1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + A( N2+J, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + A( K+J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + A( J-K, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + J = K + DO I = K, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + A( I, K+1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + A( K+1+J, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* Note that here, on exit of the loop, J = K-1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTFTTR +* + END diff --git a/SRC/dtgevc.f b/SRC/dtgevc.f index 091c3f65..b41153e0 100644 --- a/SRC/dtgevc.f +++ b/SRC/dtgevc.f @@ -1,7 +1,7 @@ SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtgex2.f b/SRC/dtgex2.f index 8351b7fd..8bdbf10f 100644 --- a/SRC/dtgex2.f +++ b/SRC/dtgex2.f @@ -1,7 +1,7 @@ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtgexc.f b/SRC/dtgexc.f index bafefea2..3c92d953 100644 --- a/SRC/dtgexc.f +++ b/SRC/dtgexc.f @@ -1,7 +1,7 @@ SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtgsen.f b/SRC/dtgsen.f index 90c65ef8..1ea65c64 100644 --- a/SRC/dtgsen.f +++ b/SRC/dtgsen.f @@ -2,7 +2,7 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, $ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/dtgsja.f b/SRC/dtgsja.f index a1c12d66..5e1c092f 100644 --- a/SRC/dtgsja.f +++ b/SRC/dtgsja.f @@ -2,7 +2,7 @@ $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtgsna.f b/SRC/dtgsna.f index b0803d89..2e1aac95 100644 --- a/SRC/dtgsna.f +++ b/SRC/dtgsna.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtgsy2.f b/SRC/dtgsy2.f index 3701e84a..d5193360 100644 --- a/SRC/dtgsy2.f +++ b/SRC/dtgsy2.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ IWORK, PQ, INFO ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/dtgsyl.f b/SRC/dtgsyl.f index 01866717..17b30e97 100644 --- a/SRC/dtgsyl.f +++ b/SRC/dtgsyl.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtpcon.f b/SRC/dtpcon.f index 84b02a85..f2f8b17a 100644 --- a/SRC/dtpcon.f +++ b/SRC/dtpcon.f @@ -1,7 +1,7 @@ SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtprfs.f b/SRC/dtprfs.f index e10d80c3..97219dce 100644 --- a/SRC/dtprfs.f +++ b/SRC/dtprfs.f @@ -1,7 +1,7 @@ SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtptri.f b/SRC/dtptri.f index 7aca893a..5bf0a108 100644 --- a/SRC/dtptri.f +++ b/SRC/dtptri.f @@ -1,6 +1,6 @@ SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtptrs.f b/SRC/dtptrs.f index 307a01d8..16731106 100644 --- a/SRC/dtptrs.f +++ b/SRC/dtptrs.f @@ -1,6 +1,6 @@ SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtpttf.f b/SRC/dtpttf.f new file mode 100644 index 00000000..7671e7de --- /dev/null +++ b/SRC/dtpttf.f @@ -0,0 +1,439 @@ + SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) +* +* Purpose +* ======= +* +* DTPTTF copies a triangular matrix A from standard packed format (TP) +* to rectangular full packed format (TF). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal format is wanted; +* = 'T': ARF in Conjugate-transpose format is wanted. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* ARF (output) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = AP( 0 ) + ELSE + ARF( 0 ) = AP( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTPTTF +* + END diff --git a/SRC/dtpttr.f b/SRC/dtpttr.f new file mode 100644 index 00000000..efa2e1f2 --- /dev/null +++ b/SRC/dtpttr.f @@ -0,0 +1,114 @@ + SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* DTPTTR copies a triangular matrix A from standard packed format (TP) +* to standard full format (TR). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular. +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* A (output) DOUBLE PRECISION array, dimension ( LDA, N ) +* On exit, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTPTTR', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + END IF +* +* + RETURN +* +* End of DTPTTR +* + END diff --git a/SRC/dtrcon.f b/SRC/dtrcon.f index 23da5927..5339a630 100644 --- a/SRC/dtrcon.f +++ b/SRC/dtrcon.f @@ -1,7 +1,7 @@ SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrevc.f b/SRC/dtrevc.f index a0215f02..8570e9cb 100644 --- a/SRC/dtrevc.f +++ b/SRC/dtrevc.f @@ -1,7 +1,7 @@ SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrexc.f b/SRC/dtrexc.f index db9be753..fac1ce74 100644 --- a/SRC/dtrexc.f +++ b/SRC/dtrexc.f @@ -1,7 +1,7 @@ SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrrfs.f b/SRC/dtrrfs.f index 77cf6c81..85950976 100644 --- a/SRC/dtrrfs.f +++ b/SRC/dtrrfs.f @@ -1,7 +1,7 @@ SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrsen.f b/SRC/dtrsen.f index 1d3ab03a..d6287783 100644 --- a/SRC/dtrsen.f +++ b/SRC/dtrsen.f @@ -1,7 +1,7 @@ SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrsna.f b/SRC/dtrsna.f index 72b5d303..d032d962 100644 --- a/SRC/dtrsna.f +++ b/SRC/dtrsna.f @@ -2,7 +2,7 @@ $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrsyl.f b/SRC/dtrsyl.f index 4c6c28e5..473b97ee 100644 --- a/SRC/dtrsyl.f +++ b/SRC/dtrsyl.f @@ -1,7 +1,7 @@ SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrti2.f b/SRC/dtrti2.f index e7ae764d..2672be9e 100644 --- a/SRC/dtrti2.f +++ b/SRC/dtrti2.f @@ -1,6 +1,6 @@ SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrtri.f b/SRC/dtrtri.f index 375813c6..b3b68cd1 100644 --- a/SRC/dtrtri.f +++ b/SRC/dtrtri.f @@ -1,6 +1,6 @@ SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrtrs.f b/SRC/dtrtrs.f index 139ea6d4..0b083a33 100644 --- a/SRC/dtrtrs.f +++ b/SRC/dtrtrs.f @@ -1,7 +1,7 @@ SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtrttf.f b/SRC/dtrttf.f new file mode 100644 index 00000000..866f6a12 --- /dev/null +++ b/SRC/dtrttf.f @@ -0,0 +1,427 @@ + SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* DTRTTF copies a triangular matrix A from standard full format (TR) +* to rectangular full packed format (TF) . +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal form is wanted; +* = 'T': ARF in Transpose form is wanted. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N). +* On entry, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the matrix A. LDA >= max(1,N). +* +* ARF (output) DOUBLE PRECISION array, dimension (NT). +* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DTRTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + ARF( 0 ) = A( 0, 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + ARF( IJ ) = A( N2+J, I ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + ARF( IJ ) = A( J-N1, L ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + ARF( IJ ) = A( I, N1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + ARF( IJ ) = A( N2+J, L ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + ARF( IJ ) = A( K+J, I ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + ARF( IJ ) = A( J-K, L ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + J = K + DO I = K, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + ARF( IJ ) = A( I, K+1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + ARF( IJ ) = A( K+1+J, L ) + IJ = IJ + 1 + END DO + END DO +* Note that here, on exit of the loop, J = K-1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of DTRTTF +* + END diff --git a/SRC/dtrttp.f b/SRC/dtrttp.f new file mode 100644 index 00000000..ea4db24a --- /dev/null +++ b/SRC/dtrttp.f @@ -0,0 +1,114 @@ + SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- and Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* DTRTTP copies a triangular matrix A from full format (TR) to standard +* packed format (TP). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular. +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrices AP and A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* On exit, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AP (output) DOUBLE PRECISION array, dimension (N*(N+1)/2 +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) 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( 'DTRTTP', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + END IF +* +* + RETURN +* +* End of DTRTTP +* + END diff --git a/SRC/dtzrqf.f b/SRC/dtzrqf.f index 27f2520d..4395ba68 100644 --- a/SRC/dtzrqf.f +++ b/SRC/dtzrqf.f @@ -1,6 +1,6 @@ SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dtzrzf.f b/SRC/dtzrzf.f index 378eefe1..759dc375 100644 --- a/SRC/dtzrzf.f +++ b/SRC/dtzrzf.f @@ -1,6 +1,6 @@ SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/dzsum1.f b/SRC/dzsum1.f index 0b6c60e7..f6e8ca7b 100644 --- a/SRC/dzsum1.f +++ b/SRC/dzsum1.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/icmax1.f b/SRC/icmax1.f index ef36a0e9..3eb6b8ad 100644 --- a/SRC/icmax1.f +++ b/SRC/icmax1.f @@ -1,6 +1,6 @@ INTEGER FUNCTION ICMAX1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ieeeck.f b/SRC/ieeeck.f index ac4aff85..3b48899b 100644 --- a/SRC/ieeeck.f +++ b/SRC/ieeeck.f @@ -1,6 +1,6 @@ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ila_len_trim.f b/SRC/ila_len_trim.f deleted file mode 100644 index 7eced971..00000000 --- a/SRC/ila_len_trim.f +++ /dev/null @@ -1,42 +0,0 @@ - INTEGER FUNCTION ILA_LEN_TRIM(SUBNAM) -C -C -- LAPACK auxiliary routine (version 3.1) -- -C Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -C October 2006 -C -C .. Scalar Arguments .. - CHARACTER*(*) SUBNAM -C .. -C -C Purpose -C ======= -C -C ILA_LEN_TRIM is called from testing and timing routines to remove -C trailing spaces from its argument. It is included in the library -C for possible use within a user's XERBLA error-handing routine. -C -C Arguments -C ========= -C -C SUBNAM (input) CHARACTER*(*) -C Provides the string. -C -C RETURN VALUE: INTEGER -C = N > 0 : The location of the last non-blank. -C = 0 : The entire string is blank. -C -C .. Local Scalars .. - INTEGER I -C .. -C .. Intrinsic Functions .. - INTRINSIC LEN -C .. - - DO I = LEN(SUBNAM),1,-1 - IF (SUBNAM(I:I).NE.' ') THEN - ILA_LEN_TRIM = I - RETURN - END IF - END DO - ILA_LEN_TRIM = 0 - END diff --git a/SRC/ilaclc.f b/SRC/ilaclc.f index 019c8f55..0e021afa 100644 --- a/SRC/ilaclc.f +++ b/SRC/ilaclc.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILACLC(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! @@ -39,7 +39,7 @@ PARAMETER ( ZERO = (0.0E+0, 0.0E+0) ) ! .. ! .. Local Scalars .. - INTEGER I, J + INTEGER I ! .. ! .. Executable Statements .. ! diff --git a/SRC/ilaclr.f b/SRC/ilaclr.f index 89d04e74..2a9f9803 100644 --- a/SRC/ilaclr.f +++ b/SRC/ilaclr.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILACLR(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! diff --git a/SRC/iladiag.f b/SRC/iladiag.f new file mode 100644 index 00000000..b71b32ab --- /dev/null +++ b/SRC/iladiag.f @@ -0,0 +1,48 @@ + INTEGER FUNCTION ILADIAG( DIAG ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* October 2008 +* .. Scalar Arguments .. + CHARACTER DIAG +* .. +* +* Purpose +* ======= +* +* This subroutine translated from a character string specifying if a +* matrix has unit diagonal or not to the relevant BLAST-specified +* integer constant. +* +* ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a +* character indicating a unit or non-unit diagonal. Otherwise ILADIAG +* returns the constant value corresponding to DIAG. +* +* Arguments +* ========= +* DIAG (input) CHARACTER*1 +* = 'N': A is non-unit triangular; +* = 'U': A is unit triangular. +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_NON_UNIT_DIAG, BLAS_UNIT_DIAG + PARAMETER ( BLAS_NON_UNIT_DIAG = 131, BLAS_UNIT_DIAG = 132 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( DIAG, 'N' ) ) THEN + ILADIAG = BLAS_NON_UNIT_DIAG + ELSE IF( LSAME( DIAG, 'U' ) ) THEN + ILADIAG = BLAS_UNIT_DIAG + ELSE + ILADIAG = -1 + END IF + RETURN +* +* End of ILADIAG +* + END diff --git a/SRC/iladlc.f b/SRC/iladlc.f index fb983d6b..2ef71805 100644 --- a/SRC/iladlc.f +++ b/SRC/iladlc.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILADLC(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! @@ -39,7 +39,7 @@ PARAMETER ( ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. - INTEGER I, J + INTEGER I ! .. ! .. Executable Statements .. ! diff --git a/SRC/iladlr.f b/SRC/iladlr.f index 94dfe051..49aaee19 100644 --- a/SRC/iladlr.f +++ b/SRC/iladlr.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILADLR(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! diff --git a/SRC/ilaenv.f b/SRC/ilaenv.f index b0d2c005..5e89f306 100644 --- a/SRC/ilaenv.f +++ b/SRC/ilaenv.f @@ -1,6 +1,6 @@ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/ilaprec.f b/SRC/ilaprec.f new file mode 100644 index 00000000..0166282e --- /dev/null +++ b/SRC/ilaprec.f @@ -0,0 +1,57 @@ + INTEGER FUNCTION ILAPREC( PREC ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* October 2008 +* .. Scalar Arguments .. + CHARACTER PREC +* .. +* +* Purpose +* ======= +* +* This subroutine translated from a character string specifying an +* intermediate precision to the relevant BLAST-specified integer +* constant. +* +* ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a +* character indicating a supported intermediate precision. Otherwise +* ILAPREC returns the constant value corresponding to PREC. +* +* Arguments +* ========= +* PREC (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'S': Single +* = 'D': Double +* = 'I': Indigenous +* = 'X', 'E': Extra +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_PREC_SINGLE, BLAS_PREC_DOUBLE, BLAS_PREC_INDIGENOUS, + $ BLAS_PREC_EXTRA + PARAMETER ( BLAS_PREC_SINGLE = 211, BLAS_PREC_DOUBLE = 212, + $ BLAS_PREC_INDIGENOUS = 213, BLAS_PREC_EXTRA = 214 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( PREC, 'S' ) ) THEN + ILAPREC = BLAS_PREC_SINGLE + ELSE IF( LSAME( PREC, 'D' ) ) THEN + ILAPREC = BLAS_PREC_DOUBLE + ELSE IF( LSAME( PREC, 'I' ) ) THEN + ILAPREC = BLAS_PREC_INDIGENOUS + ELSE IF( LSAME( PREC, 'X' ) .OR. LSAME( PREC, 'E' ) ) THEN + ILAPREC = BLAS_PREC_EXTRA + ELSE + ILAPREC = -1 + END IF + RETURN +* +* End of ILAPREC +* + END diff --git a/SRC/ilaslc.f b/SRC/ilaslc.f index 438dee61..baa51dba 100644 --- a/SRC/ilaslc.f +++ b/SRC/ilaslc.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILASLC(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! @@ -39,7 +39,7 @@ PARAMETER ( ZERO = 0.0D+0 ) ! .. ! .. Local Scalars .. - INTEGER I, J + INTEGER I ! .. ! .. Executable Statements .. ! diff --git a/SRC/ilaslr.f b/SRC/ilaslr.f index dceb68a3..80e8780e 100644 --- a/SRC/ilaslr.f +++ b/SRC/ilaslr.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILASLR(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! diff --git a/SRC/ilatrans.f b/SRC/ilatrans.f new file mode 100644 index 00000000..3e6b4c8d --- /dev/null +++ b/SRC/ilatrans.f @@ -0,0 +1,53 @@ + INTEGER FUNCTION ILATRANS( TRANS ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* October 2008 +* .. Scalar Arguments .. + CHARACTER TRANS +* .. +* +* Purpose +* ======= +* +* This subroutine translates from a character string specifying a +* transposition operation to the relevant BLAST-specified integer +* constant. +* +* ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not +* a character indicating a transposition operator. Otherwise ILATRANS +* returns the constant value corresponding to TRANS. +* +* Arguments +* ========= +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': No transpose +* = 'T': Transpose +* = 'C': Conjugate transpose +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_NO_TRANS, BLAS_TRANS, BLAS_CONJ_TRANS + PARAMETER ( BLAS_NO_TRANS = 111, BLAS_TRANS = 112, + $ BLAS_CONJ_TRANS = 113 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( TRANS, 'N' ) ) THEN + ILATRANS = BLAS_NO_TRANS + ELSE IF( LSAME( TRANS, 'T' ) ) THEN + ILATRANS = BLAS_TRANS + ELSE IF( LSAME( TRANS, 'C' ) ) THEN + ILATRANS = BLAS_CONJ_TRANS + ELSE + ILATRANS = -1 + END IF + RETURN +* +* End of ILATRANS +* + END diff --git a/SRC/ilauplo.f b/SRC/ilauplo.f new file mode 100644 index 00000000..6085c927 --- /dev/null +++ b/SRC/ilauplo.f @@ -0,0 +1,48 @@ + INTEGER FUNCTION ILAUPLO( UPLO ) +* +* -- LAPACK routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* October 2008 +* .. Scalar Arguments .. + CHARACTER UPLO +* .. +* +* Purpose +* ======= +* +* This subroutine translated from a character string specifying a +* upper- or lower-triangular matrix to the relevant BLAST-specified +* integer constant. +* +* ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not +* a character indicating an upper- or lower-triangular matrix. +* Otherwise ILAUPLO returns the constant value corresponding to UPLO. +* +* Arguments +* ========= +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* ===================================================================== +* +* .. Parameters .. + INTEGER BLAS_UPPER, BLAS_LOWER + PARAMETER ( BLAS_UPPER = 121, BLAS_LOWER = 122 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. + IF( LSAME( UPLO, 'U' ) ) THEN + ILAUPLO = BLAS_UPPER + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + ILAUPLO = BLAS_LOWER + ELSE + ILAUPLO = -1 + END IF + RETURN +* +* End of ILAUPLO +* + END diff --git a/SRC/ilaver.f b/SRC/ilaver.f index 10ef35de..80ee5d93 100644 --- a/SRC/ilaver.f +++ b/SRC/ilaver.f @@ -1,6 +1,6 @@ SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * .. diff --git a/SRC/ilazlc.f b/SRC/ilazlc.f index 2d8718e1..794959b1 100644 --- a/SRC/ilazlc.f +++ b/SRC/ilazlc.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILAZLC(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! @@ -39,7 +39,7 @@ PARAMETER ( ZERO = (0.0D+0, 0.0D+0) ) ! .. ! .. Local Scalars .. - INTEGER I, J + INTEGER I ! .. ! .. Executable Statements .. ! diff --git a/SRC/ilazlr.f b/SRC/ilazlr.f index 8f88cc9a..71cb462e 100644 --- a/SRC/ilazlr.f +++ b/SRC/ilazlr.f @@ -1,7 +1,7 @@ INTEGER FUNCTION ILAZLR(M, N, A, LDA) IMPLICIT NONE ! -! -- LAPACK auxiliary routine (version 3.1) -- +! -- LAPACK auxiliary routine (version 3.2) -- ! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. ! December 2007 ! diff --git a/SRC/iparmq.f b/SRC/iparmq.f index d9d0af36..cad272cc 100644 --- a/SRC/iparmq.f +++ b/SRC/iparmq.f @@ -1,6 +1,6 @@ INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/izmax1.f b/SRC/izmax1.f index 7ebffee3..6088046a 100644 --- a/SRC/izmax1.f +++ b/SRC/izmax1.f @@ -1,6 +1,6 @@ INTEGER FUNCTION IZMAX1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/lsamen.f b/SRC/lsamen.f index d64dc0e0..a2710524 100644 --- a/SRC/lsamen.f +++ b/SRC/lsamen.f @@ -1,6 +1,6 @@ LOGICAL FUNCTION LSAMEN( N, CA, CB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sbdsdc.f b/SRC/sbdsdc.f index 3048b483..672d084e 100644 --- a/SRC/sbdsdc.f +++ b/SRC/sbdsdc.f @@ -1,7 +1,7 @@ SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sbdsqr.f b/SRC/sbdsqr.f index 40339577..8f2637c7 100644 --- a/SRC/sbdsqr.f +++ b/SRC/sbdsqr.f @@ -1,7 +1,7 @@ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, WORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * @@ -105,16 +105,23 @@ * The leading dimension of the array C. * LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. * -* WORK (workspace) REAL array, dimension (2*N) -* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise +* WORK (workspace) REAL array, dimension (4*N) * * INFO (output) INTEGER * = 0: successful exit * < 0: If INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm did not converge; D and E contain the -* elements of a bidiagonal matrix which is orthogonally -* similar to the input matrix B; if INFO = i, i -* elements of E have not converged to zero. +* > 0: +* if NCVT = NRU = NCC = 0, +* = 1, a split was marked by a positive value in E +* = 2, current block of Z not diagonalized after 30*N +* iterations (in inner while loop) +* = 3, termination criterion of outer while loop not met +* (program created more than N unreduced blocks) +* else NCVT = NRU = NCC = 0, +* the algorithm did not converge; D and E contain the +* elements of a bidiagonal matrix which is orthogonally +* similar to the input matrix B; if INFO = i, i +* elements of E have not converged to zero. * * Internal Parameters * =================== diff --git a/SRC/scsum1.f b/SRC/scsum1.f index ac7ef369..c7dd9395 100644 --- a/SRC/scsum1.f +++ b/SRC/scsum1.f @@ -1,6 +1,6 @@ REAL FUNCTION SCSUM1( N, CX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sdisna.f b/SRC/sdisna.f index ef9cd15d..102ed8b8 100644 --- a/SRC/sdisna.f +++ b/SRC/sdisna.f @@ -1,6 +1,6 @@ SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbbrd.f b/SRC/sgbbrd.f index 7942421c..0d3cd919 100644 --- a/SRC/sgbbrd.f +++ b/SRC/sgbbrd.f @@ -1,7 +1,7 @@ SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbcon.f b/SRC/sgbcon.f index ae688a2b..c64ad741 100644 --- a/SRC/sgbcon.f +++ b/SRC/sgbcon.f @@ -1,7 +1,7 @@ SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbequ.f b/SRC/sgbequ.f index 4a415a45..7f13b724 100644 --- a/SRC/sgbequ.f +++ b/SRC/sgbequ.f @@ -1,7 +1,7 @@ SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbequb.f b/SRC/sgbequb.f new file mode 100644 index 00000000..2ea3ae8c --- /dev/null +++ b/SRC/sgbequb.f @@ -0,0 +1,261 @@ + SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + REAL AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + REAL AB( LDAB, * ), C( * ), R( * ) +* .. +* +* Purpose +* ======= +* +* SGBEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from SGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* LDAB (input) INTEGER +* The leading dimension of the array A. LDAB >= max(1,M). +* +* R (output) REAL array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) REAL array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) REAL +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) REAL +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + REAL BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGBEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = SLAMCH( 'B' ) + LOGRDX = LOG(RADIX) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + KD = KU + 1 + DO 30 J = 1, N + DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of SGBEQUB +* + END diff --git a/SRC/sgbrfs.f b/SRC/sgbrfs.f index a8e5feba..81dcfc14 100644 --- a/SRC/sgbrfs.f +++ b/SRC/sgbrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbrfsx.f b/SRC/sgbrfsx.f new file mode 100644 index 00000000..1c1753c0 --- /dev/null +++ b/SRC/sgbrfsx.f @@ -0,0 +1,628 @@ + SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, + $ NPARAMS, N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SGBRFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* The original band matrix A, stored in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) +* Details of the LU factorization of the band matrix A, as +* computed by DGBTRF. U is stored as an upper triangular band +* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +* the multipliers used during the factorization are stored in +* rows KL+KU+2 to 2*KL+KU+1. +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from SGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) REAL array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) REAL array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SGBCON + EXTERNAL SLA_GBRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, SLANGB, SLA_GBRCOND + REAL SLAMCH, SLANGB, SLA_GBRCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGBRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = SLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) + CALL SGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, + $ WORK, IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF (REF_TYPE .NE. 0) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + IF ( NOTRAN ) THEN + CALL SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), + $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + ELSE + CALL SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), + $ WORK( 1 ), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, -1, C, INFO, WORK, IWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, -1, R, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, 0, R, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, 1, X( 1, J ), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of SGBRFSX +* + END diff --git a/SRC/sgbsv.f b/SRC/sgbsv.f index f6b502bd..b4ef802f 100644 --- a/SRC/sgbsv.f +++ b/SRC/sgbsv.f @@ -1,6 +1,6 @@ SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbsvx.f b/SRC/sgbsvx.f index 461d2edc..e05f45dd 100644 --- a/SRC/sgbsvx.f +++ b/SRC/sgbsvx.f @@ -2,7 +2,7 @@ $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbsvxx.f b/SRC/sgbsvxx.f new file mode 100644 index 00000000..57dc27c7 --- /dev/null +++ b/SRC/sgbsvxx.f @@ -0,0 +1,657 @@ + SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, + $ RCOND, RPVGRW, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SGBSVXX uses the LU factorization to compute the solution to a +* real system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. SGBSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* SGBSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* SGBSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what SGBSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose = Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input/output) REAL array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* If FACT = 'F' and EQUED is not 'N', then AB must have been +* equilibrated by the scaling factors in R and/or C. AB is not +* modified if FACT = 'F' or 'N', or if FACT = 'E' and +* EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input or output) REAL array, dimension (LDAFB,N) +* If FACT = 'F', then AFB is an input argument and on entry +* contains details of the LU factorization of the band matrix +* A, as computed by SGBTRF. U is stored as an upper triangular +* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +* and the multipliers used during the factorization are stored +* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is +* the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by SGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) REAL array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) REAL array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In SGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, I, J, KL, KU + REAL AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, SLA_GBRPVGRW + LOGICAL LSAME + REAL SLAMCH, SLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL SGBEQUB, SGBTRF, SGBTRS, SLACPY, SLAQGB, + $ XERBLA, SLASCL2, SGBRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in SGBRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until SGBRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -12 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -13 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -14 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGBSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL SGBEQUB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL SLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0 + END DO + END IF + END IF +* +* Scale the right hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL SLASCL2(N, NRHS, R, B, LDB) + ELSE + IF( COLEQU ) CALL SLASCL2(N, NRHS, C, B, LDB) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + DO 40, J = 1, N + DO 30, I = KL+1, 2*KL+KU+1 + AFB( I, J ) = AB( I-KL, J ) + 30 CONTINUE + 40 CONTINUE + CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = SLA_GBRPVGRW( N, KL, KU, INFO, AB, LDAB, AFB, + $ LDAFB ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = SLA_GBRPVGRW( N, KL, KU, N, AB, LDAB, AFB, LDAFB ) +* +* Compute the solution matrix X. +* + CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL SGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL SLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL SLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of SGBSVXX +* + END diff --git a/SRC/sgbtf2.f b/SRC/sgbtf2.f index 041b19d0..632c9904 100644 --- a/SRC/sgbtf2.f +++ b/SRC/sgbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbtrf.f b/SRC/sgbtrf.f index b33ad4d0..da3cb358 100644 --- a/SRC/sgbtrf.f +++ b/SRC/sgbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgbtrs.f b/SRC/sgbtrs.f index e6ea0a8a..c39c91c2 100644 --- a/SRC/sgbtrs.f +++ b/SRC/sgbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgebak.f b/SRC/sgebak.f index 467e5a92..59a0e516 100644 --- a/SRC/sgebak.f +++ b/SRC/sgebak.f @@ -1,7 +1,7 @@ SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgebal.f b/SRC/sgebal.f index ba9fd173..ede96d7b 100644 --- a/SRC/sgebal.f +++ b/SRC/sgebal.f @@ -1,6 +1,6 @@ SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgebd2.f b/SRC/sgebd2.f index 7c46c164..0b32dcfc 100644 --- a/SRC/sgebd2.f +++ b/SRC/sgebd2.f @@ -1,6 +1,6 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgebrd.f b/SRC/sgebrd.f index a45aaba2..eebb121d 100644 --- a/SRC/sgebrd.f +++ b/SRC/sgebrd.f @@ -1,7 +1,7 @@ SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgecon.f b/SRC/sgecon.f index 3cce1652..5d8d5b70 100644 --- a/SRC/sgecon.f +++ b/SRC/sgecon.f @@ -1,7 +1,7 @@ SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeequ.f b/SRC/sgeequ.f index d875d1f4..3033a0a8 100644 --- a/SRC/sgeequ.f +++ b/SRC/sgeequ.f @@ -1,7 +1,7 @@ SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeequb.f b/SRC/sgeequb.f new file mode 100644 index 00000000..b311da59 --- /dev/null +++ b/SRC/sgeequb.f @@ -0,0 +1,248 @@ + SUBROUTINE SGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + REAL AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + REAL A( LDA, * ), C( * ), R( * ) +* .. +* +* Purpose +* ======= +* +* SGEEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from SGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The M-by-N matrix whose equilibration factors are +* to be computed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* R (output) REAL array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) REAL array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) REAL +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) REAL +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGEEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = SLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = SLAMCH( 'B' ) + LOGRDX = LOG( RADIX ) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + DO 30 J = 1, N + DO 20 I = 1, M + R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = 1, M + C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of SGEEQUB +* + END diff --git a/SRC/sgees.f b/SRC/sgees.f index e11d617a..a64a4f65 100644 --- a/SRC/sgees.f +++ b/SRC/sgees.f @@ -1,7 +1,7 @@ SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, $ VS, LDVS, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeesx.f b/SRC/sgeesx.f index a6f78995..15a5e3bf 100644 --- a/SRC/sgeesx.f +++ b/SRC/sgeesx.f @@ -2,7 +2,7 @@ $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeev.f b/SRC/sgeev.f index 7af086a8..8023e5ea 100644 --- a/SRC/sgeev.f +++ b/SRC/sgeev.f @@ -1,7 +1,7 @@ SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, $ LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeevx.f b/SRC/sgeevx.f index 41487fe9..460419ff 100644 --- a/SRC/sgeevx.f +++ b/SRC/sgeevx.f @@ -2,7 +2,7 @@ $ VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, $ RCONDE, RCONDV, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgegs.f b/SRC/sgegs.f index a3a7d9f9..b9e911fa 100644 --- a/SRC/sgegs.f +++ b/SRC/sgegs.f @@ -2,7 +2,7 @@ $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgegv.f b/SRC/sgegv.f index 08c811c3..6cce7a76 100644 --- a/SRC/sgegv.f +++ b/SRC/sgegv.f @@ -1,7 +1,7 @@ SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgehd2.f b/SRC/sgehd2.f index 95a154e9..8db57cde 100644 --- a/SRC/sgehd2.f +++ b/SRC/sgehd2.f @@ -1,6 +1,6 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgehrd.f b/SRC/sgehrd.f index c5fe911a..fbe794b4 100644 --- a/SRC/sgehrd.f +++ b/SRC/sgehrd.f @@ -1,6 +1,6 @@ SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgejsv.f b/SRC/sgejsv.f new file mode 100644 index 00000000..054151fc --- /dev/null +++ b/SRC/sgejsv.f @@ -0,0 +1,1650 @@ + SUBROUTINE SGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, + & M, N, A, LDA, SVA, U, LDU, V, LDV, + & WORK, LWORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* -#- Scalar Arguments -#- +* + IMPLICIT NONE + INTEGER INFO, LDA, LDU, LDV, LWORK, M, N +* +* -#- Array Arguments -#- +* + REAL A( LDA, * ), SVA( N ), U( LDU, * ), V( LDV, * ), + & WORK( LWORK ) + INTEGER IWORK( * ) + CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV +* .. +* +* Purpose +* ~~~~~~~ +* SGEJSV computes the singular value decomposition (SVD) of a real M-by-N +* matrix [A], where M >= N. The SVD of [A] is written as +* +* [A] = [U] * [SIGMA] * [V]^t, +* +* where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N +* diagonal elements, [U] is an M-by-N (or M-by-M) orthonormal matrix, and +* [V] is an N-by-N orthogonal matrix. The diagonal elements of [SIGMA] are +* the singular values of [A]. The columns of [U] and [V] are the left and +* the right singular vectors of [A], respectively. The matrices [U] and [V] +* are computed and stored in the arrays U and V, respectively. The diagonal +* of [SIGMA] is computed and stored in the array SVA. +* +* Further details +* ~~~~~~~~~~~~~~~ +* SGEJSV implements a preconditioned Jacobi SVD algorithm. It uses SGEQP3, +* SGEQRF, and SGELQF as preprocessors and preconditioners. Optionally, an +* additional row pivoting can be used as a preprocessor, which in some +* cases results in much higher accuracy. An example is matrix A with the +* structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned +* diagonal matrices and C is well-conditioned matrix. In that case, complete +* pivoting in the first QR factorizations provides accuracy dependent on the +* condition number of C, and independent of D1, D2. Such higher accuracy is +* not completely understood theoretically, but it works well in practice. +* Further, if A can be written as A = B*D, with well-conditioned B and some +* diagonal D, then the high accuracy is guaranteed, both theoretically and +* in software, independent of D. For more details see [1], [2]. +* The computational range for the singular values can be the full range +* ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS +* & LAPACK routines called by SGEJSV are implemented to work in that range. +* If that is not the case, then the restriction for safe computation with +* the singular values in the range of normalized IEEE numbers is that the +* spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not +* overflow. This code (SGEJSV) is best used in this restricted range, +* meaning that singular values of magnitude below ||A||_2 / SLAMCH('O') are +* returned as zeros. See JOBR for details on this. +* Further, this implementation is somewhat slower than the one described +* in [1,2] due to replacement of some non-LAPACK components, and because +* the choice of some tuning parameters in the iterative part (SGESVJ) is +* left to the implementer on a particular machine. +* The rank revealing QR factorization (in this code: SGEQP3) should be +* implemented as in [3]. We have a new version of SGEQP3 under development +* that is more robust than the current one in LAPACK, with a cleaner cut in +* rank defficient cases. It will be available in the SIGMA library [4]. +* If M is much larger than N, it is obvious that the inital QRF with +* column pivoting can be preprocessed by the QRF without pivoting. That +* well known trick is not used in SGEJSV because in some cases heavy row +* weighting can be treated with complete pivoting. The overhead in cases +* M much larger than N is then only due to pivoting, but the benefits in +* terms of accuracy have prevailed. The implementer/user can incorporate +* this extra QRF step easily. The implementer can also improve data movement +* (matrix transpose, matrix copy, matrix transposed copy) - this +* implementation of SGEJSV uses only the simplest, naive data movement. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* References +* ~~~~~~~~~~ +* [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +* LAPACK Working note 169. +* [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +* LAPACK Working note 170. +* [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR +* factorization software - a case study. +* ACM Trans. math. Softw. Vol. 35, No 2 (2008), pp. 1-28. +* LAPACK Working note 176. +* [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +* QSVD, (H,K)-SVD computations. +* Department of Mathematics, University of Zagreb, 2008. +* +* Bugs, examples and comments +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Please report all bugs and send interesting examples and/or comments to +* drmac@math.hr. Thank you. +* +* Arguments +* ~~~~~~~~~ +*............................................................................ +*. JOBA (input) CHARACTER*1 +*. Specifies the level of accuracy: +*. = 'C': This option works well (high relative accuracy) if A = B * D, +*. with well-conditioned B and arbitrary diagonal matrix D. +*. The accuracy cannot be spoiled by COLUMN scaling. The +*. accuracy of the computed output depends on the condition of +*. B, and the procedure aims at the best theoretical accuracy. +*. The relative error max_{i=1:N}|d sigma_i| / sigma_i is +*. bounded by f(M,N)*epsilon* cond(B), independent of D. +*. The input matrix is preprocessed with the QRF with column +*. pivoting. This initial preprocessing and preconditioning by +*. a rank revealing QR factorization is common for all values of +*. JOBA. Additional actions are specified as follows: +*. = 'E': Computation as with 'C' with an additional estimate of the +*. condition number of B. It provides a realistic error bound. +*. = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings +*. D1, D2, and well-conditioned matrix C, this option gives +*. higher accuracy than the 'C' option. If the structure of the +*. input matrix is not known, and relative accuracy is +*. desirable, then this option is advisable. The input matrix A +*. is preprocessed with QR factorization with FULL (row and +*. column) pivoting. +*. = 'G' Computation as with 'F' with an additional estimate of the +*. condition number of B, where A=D*B. If A has heavily weighted +*. rows, then using this condition number gives too pessimistic +*. error bound. +*. = 'A': Small singular values are the noise and the matrix is treated +*. as numerically rank defficient. The error in the computed +*. singular values is bounded by f(m,n)*epsilon*||A||. +*. The computed SVD A = U * S * V^t restores A up to +*. f(m,n)*epsilon*||A||. +*. This gives the procedure the licence to discard (set to zero) +*. all singular values below N*epsilon*||A||. +*. = 'R': Similar as in 'A'. Rank revealing property of the initial +*. QR factorization is used do reveal (using triangular factor) +*. a gap sigma_{r+1} < epsilon * sigma_r in which case the +*. numerical RANK is declared to be r. The SVD is computed with +*. absolute error bounds, but more accurately than with 'A'. +*. +*. JOBU (input) CHARACTER*1 +*. Specifies whether to compute the columns of U: +*. = 'U': N columns of U are returned in the array U. +*. = 'F': full set of M left sing. vectors is returned in the array U. +*. = 'W': U may be used as workspace of length M*N. See the description +*. of U. +*. = 'N': U is not computed. +*. +*. JOBV (input) CHARACTER*1 +*. Specifies whether to compute the matrix V: +*. = 'V': N columns of V are returned in the array V; Jacobi rotations +*. are not explicitly accumulated. +*. = 'J': N columns of V are returned in the array V, but they are +*. computed as the product of Jacobi rotations. This option is +*. allowed only if JOBU .NE. 'N', i.e. in computing the full SVD. +*. = 'W': V may be used as workspace of length N*N. See the description +*. of V. +*. = 'N': V is not computed. +*. +*. JOBR (input) CHARACTER*1 +*. Specifies the RANGE for the singular values. Issues the licence to +*. set to zero small positive singular values if they are outside +*. specified range. If A .NE. 0 is scaled so that the largest singular +*. value of c*A is around SQRT(BIG), BIG=SLAMCH('O'), then JOBR issues +*. the licence to kill columns of A whose norm in c*A is less than +*. SQRT(SFMIN) (for JOBR.EQ.'R'), or less than SMALL=SFMIN/EPSLN, +*. where SFMIN=SLAMCH('S'), EPSLN=SLAMCH('E'). +*. = 'N': Do not kill small columns of c*A. This option assumes that +*. BLAS and QR factorizations and triangular solvers are +*. implemented to work in that range. If the condition of A +*. is greater than BIG, use SGESVJ. +*. = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] +*. (roughly, as described above). This option is recommended. +*. ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*. For computing the singular values in the FULL range [SFMIN,BIG] +*. use SGESVJ. +*. +*. JOBT (input) CHARACTER*1 +*. If the matrix is square then the procedure may determine to use +*. transposed A if A^t seems to be better with respect to convergence. +*. If the matrix is not square, JOBT is ignored. This is subject to +*. changes in the future. +*. The decision is based on two values of entropy over the adjoint +*. orbit of A^t * A. See the descriptions of WORK(6) and WORK(7). +*. = 'T': transpose if entropy test indicates possibly faster +*. convergence of Jacobi process if A^t is taken as input. If A is +*. replaced with A^t, then the row pivoting is included automatically. +*. = 'N': do not speculate. +*. This option can be used to compute only the singular values, or the +*. full SVD (U, SIGMA and V). For only one set of singular vectors +*. (U or V), the caller should provide both U and V, as one of the +*. matrices is used as workspace if the matrix A is transposed. +*. The implementer can easily remove this constraint and make the +*. code more complicated. See the descriptions of U and V. +*. +*. JOBP (input) CHARACTER*1 +*. Issues the licence to introduce structured perturbations to drown +*. denormalized numbers. This licence should be active if the +*. denormals are poorly implemented, causing slow computation, +*. especially in cases of fast convergence (!). For details see [1,2]. +*. For the sake of simplicity, this perturbations are included only +*. when the full SVD or only the singular values are requested. The +*. implementer/user can easily add the perturbation for the cases of +*. computing one set of singular vectors. +*. = 'P': introduce perturbation +*. = 'N': do not perturb +*............................................................................ +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. M >= N >= 0. +* +* A (input/workspace) REAL array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* SVA (workspace/output) REAL array, dimension (N) +* On exit, +* - For WORK(1)/WORK(2) = ONE: The singular values of A. During the +* computation SVA contains Euclidean column norms of the +* iterated matrices in the array A. +* - For WORK(1) .NE. WORK(2): The singular values of A are +* (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if +* sigma_max(A) overflows or if small singular values have been +* saved from underflow by scaling the input matrix A. +* - If JOBR='R' then some of the singular values may be returned +* as exact zeros obtained by "set to zero" because they are +* below the numerical rank threshold or are denormalized numbers. +* +* U (workspace/output) REAL array, dimension ( LDU, N ) +* If JOBU = 'U', then U contains on exit the M-by-N matrix of +* the left singular vectors. +* If JOBU = 'F', then U contains on exit the M-by-M matrix of +* the left singular vectors, including an ONB +* of the orthogonal complement of the Range(A). +* If JOBU = 'W' .AND. (JOBV.EQ.'V' .AND. JOBT.EQ.'T' .AND. M.EQ.N), +* then U is used as workspace if the procedure +* replaces A with A^t. In that case, [V] is computed +* in U as left singular vectors of A^t and then +* copied back to the V array. This 'W' option is just +* a reminder to the caller that in this case U is +* reserved as workspace of length N*N. +* If JOBU = 'N' U is not referenced. +* +* LDU (input) INTEGER +* The leading dimension of the array U, LDU >= 1. +* IF JOBU = 'U' or 'F' or 'W', then LDU >= M. +* +* V (workspace/output) REAL array, dimension ( LDV, N ) +* If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of +* the right singular vectors; +* If JOBV = 'W', AND (JOBU.EQ.'U' AND JOBT.EQ.'T' AND M.EQ.N), +* then V is used as workspace if the pprocedure +* replaces A with A^t. In that case, [U] is computed +* in V as right singular vectors of A^t and then +* copied back to the U array. This 'W' option is just +* a reminder to the caller that in this case V is +* reserved as workspace of length N*N. +* If JOBV = 'N' V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV >= 1. +* If JOBV = 'V' or 'J' or 'W', then LDV >= N. +* +* WORK (workspace/output) REAL array, dimension at least LWORK. +* On exit, +* WORK(1) = SCALE = WORK(2) / WORK(1) is the scaling factor such +* that SCALE*SVA(1:N) are the computed singular values +* of A. (See the description of SVA().) +* WORK(2) = See the description of WORK(1). +* WORK(3) = SCONDA is an estimate for the condition number of +* column equilibrated A. (If JOBA .EQ. 'E' or 'G') +* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1). +* It is computed using SPOCON. It holds +* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA +* where R is the triangular factor from the QRF of A. +* However, if R is truncated and the numerical rank is +* determined to be strictly smaller than N, SCONDA is +* returned as -1, thus indicating that the smallest +* singular values might be lost. +* +* If full SVD is needed, the following two condition numbers are +* useful for the analysis of the algorithm. They are provied for +* a developer/implementer who is familiar with the details of +* the method. +* +* WORK(4) = an estimate of the scaled condition number of the +* triangular factor in the first QR factorization. +* WORK(5) = an estimate of the scaled condition number of the +* triangular factor in the second QR factorization. +* The following two parameters are computed if JOBT .EQ. 'T'. +* They are provided for a developer/implementer who is familiar +* with the details of the method. +* +* WORK(6) = the entropy of A^t*A :: this is the Shannon entropy +* of diag(A^t*A) / Trace(A^t*A) taken as point in the +* probability simplex. +* WORK(7) = the entropy of A*A^t. +* +* LWORK (input) INTEGER +* Length of WORK to confirm proper allocation of work space. +* LWORK depends on the job: +* +* If only SIGMA is needed ( JOBU.EQ.'N', JOBV.EQ.'N' ) and +* -> .. no scaled condition estimate required ( JOBE.EQ.'N'): +* LWORK >= max(2*M+N,4*N+1,7). This is the minimal requirement. +* For optimal performance (blocked code) the optimal value +* is LWORK >= max(2*M+N,3*N+(N+1)*NB,7). Here NB is the optimal +* block size for xGEQP3/xGEQRF. +* -> .. an estimate of the scaled condition number of A is +* required (JOBA='E', 'G'). In this case, LWORK is the maximum +* of the above and N*N+4*N, i.e. LWORK >= max(2*M+N,N*N+4N,7). +* +* If SIGMA and the right singular vectors are needed (JOBV.EQ.'V'), +* -> the minimal requirement is LWORK >= max(2*N+M,7). +* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), +* where NB is the optimal block size. +* +* If SIGMA and the left singular vectors are needed +* -> the minimal requirement is LWORK >= max(2*N+M,7). +* -> For optimal performance, LWORK >= max(2*N+M,2*N+N*NB,7), +* where NB is the optimal block size. +* +* If full SVD is needed ( JOBU.EQ.'U' or 'F', JOBV.EQ.'V' ) and +* -> .. the singular vectors are computed without explicit +* accumulation of the Jacobi rotations, LWORK >= 6*N+2*N*N +* -> .. in the iterative part, the Jacobi rotations are +* explicitly accumulated (option, see the description of JOBV), +* then the minimal requirement is LWORK >= max(M+3*N+N*N,7). +* For better performance, if NB is the optimal block size, +* LWORK >= max(3*N+N*N+M,3*N+N*N+N*NB,7). +* +* IWORK (workspace/output) INTEGER array, dimension M+3*N. +* On exit, +* IWORK(1) = the numerical rank determined after the initial +* QR factorization with pivoting. See the descriptions +* of JOBA and JOBR. +* IWORK(2) = the number of the computed nonzero singular values +* IWORK(3) = if nonzero, a warning message: +* If IWORK(3).EQ.1 then some of the column norms of A +* were denormalized floats. The requested high accuracy +* is not warranted by the data. +* +* INFO (output) INTEGER +* < 0 : if INFO = -i, then the i-th argument had an illegal value. +* = 0 : successfull exit; +* > 0 : SGEJSV did not converge in the maximal allowed number +* of sweeps. The computed values may be inaccurate. +* +*............................................................................ +* +* Local Parameters: +* + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* +* Local Scalars: +* + REAL AAPP, AAQQ, AATMAX, AATMIN, BIG, BIG1, COND_OK, + & CONDR1, CONDR2, ENTRA, ENTRAT, EPSLN, MAXPRJ, SCALEM, + & SCONDA, SFMIN, SMALL, TEMP1, USCAL1, USCAL2, XSC + INTEGER IERR, N1, NR, NUMRANK, p, q, WARNING + LOGICAL ALMORT, DEFR, ERREST, GOSCAL, JRACC, KILL, LSVEC, + & L2ABER, L2KILL, L2PERT, L2RANK, L2TRAN, + & NOSCAL, ROWPIV, RSVEC, TRANSP +* +* Intrinsic Functions: +* + INTRINSIC ABS, ALOG, AMAX1, AMIN1, FLOAT, + & MAX0, MIN0, NINT, SIGN, SQRT +* +* External Functions: +* + REAL SLAMCH, SNRM2 + INTEGER ISAMAX + LOGICAL LSAME + EXTERNAL ISAMAX, LSAME, SLAMCH, SNRM2 +* +* External Subroutines ( BLAS, LAPACK ): +* + EXTERNAL SCOPY, SGELQF, SGEQP3, SGEQRF, SLACPY, SLASCL, + & SLASET, SLASSQ, SLASWP, SORGQR, SORMLQ, + & SORMQR, SPOCON, SSCAL, SSWAP, STRSM, XERBLA +* + EXTERNAL SGESVJ +* +*............................................................................ +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) .OR. LSAME( JOBU, 'F' ) + JRACC = LSAME( JOBV, 'J' ) + RSVEC = LSAME( JOBV, 'V' ) .OR. JRACC + ROWPIV = LSAME( JOBA, 'F' ) .OR. LSAME( JOBA, 'G' ) + L2RANK = LSAME( JOBA, 'R' ) + L2ABER = LSAME( JOBA, 'A' ) + ERREST = LSAME( JOBA, 'E' ) .OR. LSAME( JOBA, 'G' ) + L2TRAN = LSAME( JOBT, 'T' ) + L2KILL = LSAME( JOBR, 'R' ) + DEFR = LSAME( JOBR, 'N' ) + L2PERT = LSAME( JOBP, 'P' ) +* + IF ( .NOT.(ROWPIV .OR. L2RANK .OR. L2ABER .OR. + & ERREST .OR. LSAME( JOBA, 'C' ) )) THEN + INFO = - 1 + ELSE IF ( .NOT.( LSVEC .OR. LSAME( JOBU, 'N' ) .OR. + & LSAME( JOBU, 'W' )) ) THEN + INFO = - 2 + ELSE IF ( .NOT.( RSVEC .OR. LSAME( JOBV, 'N' ) .OR. + & LSAME( JOBV, 'W' )) .OR. ( JRACC .AND. (.NOT.LSVEC) ) ) THEN + INFO = - 3 + ELSE IF ( .NOT. ( L2KILL .OR. DEFR ) ) THEN + INFO = - 4 + ELSE IF ( .NOT. ( L2TRAN .OR. LSAME( JOBT, 'N' ) ) ) THEN + INFO = - 5 + ELSE IF ( .NOT. ( L2PERT .OR. LSAME( JOBP, 'N' ) ) ) THEN + INFO = - 6 + ELSE IF ( M .LT. 0 ) THEN + INFO = - 7 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN + INFO = - 8 + ELSE IF ( LDA .LT. M ) THEN + INFO = - 10 + ELSE IF ( LSVEC .AND. ( LDU .LT. M ) ) THEN + INFO = - 13 + ELSE IF ( RSVEC .AND. ( LDV .LT. N ) ) THEN + INFO = - 14 + ELSE IF ( (.NOT.(LSVEC .OR. RSVEC .OR. ERREST).AND. + & (LWORK .LT. MAX0(7,4*N+1,2*M+N))) .OR. + & (.NOT.(LSVEC .OR. LSVEC) .AND. ERREST .AND. + & (LWORK .LT. MAX0(7,4*N+N*N,2*M+N))) .OR. + & (LSVEC .AND. (.NOT.RSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR. + & (RSVEC .AND. (.NOT.LSVEC) .AND. (LWORK .LT. MAX0(7,2*N+M))) .OR. + & (LSVEC .AND. RSVEC .AND. .NOT.JRACC .AND. (LWORK.LT.6*N+2*N*N)) + & .OR. (LSVEC.AND.RSVEC.AND.JRACC.AND.LWORK.LT.MAX0(7,M+3*N+N*N))) + & THEN + INFO = - 17 + ELSE +* #:) + INFO = 0 + END IF +* + IF ( INFO .NE. 0 ) THEN +* #:( + CALL XERBLA( 'SGEJSV', - INFO ) + END IF +* +* Quick return for void matrix (Y3K safe) +* #:) + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN +* +* Determine whether the matrix U should be M x N or M x M +* + IF ( LSVEC ) THEN + N1 = N + IF ( LSAME( JOBU, 'F' ) ) N1 = M + END IF +* +* Set numerical parameters +* +*! NOTE: Make sure SLAMCH() does not fail on the target architecture. +* + EPSLN = SLAMCH('Epsilon') + SFMIN = SLAMCH('SafeMinimum') + SMALL = SFMIN / EPSLN + BIG = SLAMCH('O') +* +* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N +* +*(!) If necessary, scale SVA() to protect the largest norm from +* overflow. It is possible that this scaling pushes the smallest +* column norm left from the underflow threshold (extreme case). +* + SCALEM = ONE / SQRT(FLOAT(M)*FLOAT(N)) + NOSCAL = .TRUE. + GOSCAL = .TRUE. + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 9 + CALL XERBLA( 'SGEJSV', -INFO ) + RETURN + END IF + AAQQ = SQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCAL ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCAL = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALEM ) + IF ( GOSCAL ) THEN + GOSCAL = .FALSE. + CALL SSCAL( p-1, SCALEM, SVA, 1 ) + END IF + END IF + 1874 CONTINUE +* + IF ( NOSCAL ) SCALEM = ONE +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + AAPP = AMAX1( AAPP, SVA(p) ) + IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) ) + 4781 CONTINUE +* +* Quick return for zero M x N matrix +* #:) + IF ( AAPP .EQ. ZERO ) THEN + IF ( LSVEC ) CALL SLASET( 'G', M, N1, ZERO, ONE, U, LDU ) + IF ( RSVEC ) CALL SLASET( 'G', N, N, ZERO, ONE, V, LDV ) + WORK(1) = ONE + WORK(2) = ONE + IF ( ERREST ) WORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + WORK(4) = ONE + WORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + WORK(6) = ZERO + WORK(7) = ZERO + END IF + IWORK(1) = 0 + IWORK(2) = 0 + RETURN + END IF +* +* Issue warning if denormalized column norms detected. Override the +* high relative accuracy request. Issue licence to kill columns +* (set them to zero) whose norm is less than sigma_max / BIG (roughly). +* #:( + WARNING = 0 + IF ( AAQQ .LE. SFMIN ) THEN + L2RANK = .TRUE. + L2KILL = .TRUE. + WARNING = 1 + END IF +* +* Quick return for one-column matrix +* #:) + IF ( N .EQ. 1 ) THEN +* + IF ( LSVEC ) THEN + CALL SLASCL( 'G',0,0,SVA(1),SCALEM, M,1,A(1,1),LDA,IERR ) + CALL SLACPY( 'A', M, 1, A, LDA, U, LDU ) +* computing all M left singular vectors of the M x 1 matrix + IF ( N1 .NE. N ) THEN + CALL SGEQRF( M, N, U,LDU, WORK, WORK(N+1),LWORK-N,IERR ) + CALL SORGQR( M,N1,1, U,LDU,WORK,WORK(N+1),LWORK-N,IERR ) + CALL SCOPY( M, A(1,1), 1, U(1,1), 1 ) + END IF + END IF + IF ( RSVEC ) THEN + V(1,1) = ONE + END IF + IF ( SVA(1) .LT. (BIG*SCALEM) ) THEN + SVA(1) = SVA(1) / SCALEM + SCALEM = ONE + END IF + WORK(1) = ONE / SCALEM + WORK(2) = ONE + IF ( SVA(1) .NE. ZERO ) THEN + IWORK(1) = 1 + IF ( ( SVA(1) / SCALEM) .GE. SFMIN ) THEN + IWORK(2) = 1 + ELSE + IWORK(2) = 0 + END IF + ELSE + IWORK(1) = 0 + IWORK(2) = 0 + END IF + IF ( ERREST ) WORK(3) = ONE + IF ( LSVEC .AND. RSVEC ) THEN + WORK(4) = ONE + WORK(5) = ONE + END IF + IF ( L2TRAN ) THEN + WORK(6) = ZERO + WORK(7) = ZERO + END IF + RETURN +* + END IF +* + TRANSP = .FALSE. + L2TRAN = L2TRAN .AND. ( M .EQ. N ) +* + AATMAX = -ONE + AATMIN = BIG + IF ( ROWPIV .OR. L2TRAN ) THEN +* +* Compute the row norms, needed to determine row pivoting sequence +* (in the case of heavily row weighted A, row pivoting is strongly +* advised) and to collect information needed to compare the +* structures of A * A^t and A^t * A (in the case L2TRAN.EQ..TRUE.). +* + IF ( L2TRAN ) THEN + DO 1950 p = 1, M + XSC = ZERO + TEMP1 = ZERO + CALL SLASSQ( N, A(p,1), LDA, XSC, TEMP1 ) +* SLASSQ gets both the ell_2 and the ell_infinity norm +* in one pass through the vector + WORK(M+N+p) = XSC * SCALEM + WORK(N+p) = XSC * (SCALEM*SQRT(TEMP1)) + AATMAX = AMAX1( AATMAX, WORK(N+p) ) + IF (WORK(N+p) .NE. ZERO) AATMIN = AMIN1(AATMIN,WORK(N+p)) + 1950 CONTINUE + ELSE + DO 1904 p = 1, M + WORK(M+N+p) = SCALEM*ABS( A(p,ISAMAX(N,A(p,1),LDA)) ) + AATMAX = AMAX1( AATMAX, WORK(M+N+p) ) + AATMIN = AMIN1( AATMIN, WORK(M+N+p) ) + 1904 CONTINUE + END IF +* + END IF +* +* For square matrix A try to determine whether A^t would be better +* input for the preconditioned Jacobi SVD, with faster convergence. +* The decision is based on an O(N) function of the vector of column +* and row norms of A, based on the Shannon entropy. This should give +* the right choice in most cases when the difference actually matters. +* It may fail and pick the slower converging side. +* + ENTRA = ZERO + ENTRAT = ZERO + IF ( L2TRAN ) THEN +* + XSC = ZERO + TEMP1 = ZERO + CALL SLASSQ( N, SVA, 1, XSC, TEMP1 ) + TEMP1 = ONE / TEMP1 +* + ENTRA = ZERO + DO 1113 p = 1, N + BIG1 = ( ( SVA(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRA = ENTRA + BIG1 * ALOG(BIG1) + 1113 CONTINUE + ENTRA = - ENTRA / ALOG(FLOAT(N)) +* +* Now, SVA().^2/Trace(A^t * A) is a point in the probability simplex. +* It is derived from the diagonal of A^t * A. Do the same with the +* diagonal of A * A^t, compute the entropy of the corresponding +* probability distribution. Note that A * A^t and A^t * A have the +* same trace. +* + ENTRAT = ZERO + DO 1114 p = N+1, N+M + BIG1 = ( ( WORK(p) / XSC )**2 ) * TEMP1 + IF ( BIG1 .NE. ZERO ) ENTRAT = ENTRAT + BIG1 * ALOG(BIG1) + 1114 CONTINUE + ENTRAT = - ENTRAT / ALOG(FLOAT(M)) +* +* Analyze the entropies and decide A or A^t. Smaller entropy +* usually means better input for the algorithm. +* + TRANSP = ( ENTRAT .LT. ENTRA ) +* +* If A^t is better than A, transpose A. +* + IF ( TRANSP ) THEN +* In an optimal implementation, this trivial transpose +* should be replaced with faster transpose. + DO 1115 p = 1, N - 1 + DO 1116 q = p + 1, N + TEMP1 = A(q,p) + A(q,p) = A(p,q) + A(p,q) = TEMP1 + 1116 CONTINUE + 1115 CONTINUE + DO 1117 p = 1, N + WORK(M+N+p) = SVA(p) + SVA(p) = WORK(N+p) + 1117 CONTINUE + TEMP1 = AAPP + AAPP = AATMAX + AATMAX = TEMP1 + TEMP1 = AAQQ + AAQQ = AATMIN + AATMIN = TEMP1 + KILL = LSVEC + LSVEC = RSVEC + RSVEC = KILL +* + ROWPIV = .TRUE. + END IF +* + END IF +* END IF L2TRAN +* +* Scale the matrix so that its maximal singular value remains less +* than SQRT(BIG) -- the matrix is scaled so that its maximal column +* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep +* SQRT(BIG) instead of BIG is the fact that SGEJSV uses LAPACK and +* BLAS routines that, in some implementations, are not capable of +* working in the full interval [SFMIN,BIG] and that they may provoke +* overflows in the intermediate results. If the singular values spread +* from SFMIN to BIG, then SGESVJ will compute them. So, in that case, +* one should use SGESVJ instead of SGEJSV. +* + BIG1 = SQRT( BIG ) + TEMP1 = SQRT( BIG / FLOAT(N) ) +* + CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, N, 1, SVA, N, IERR ) + IF ( AAQQ .GT. (AAPP * SFMIN) ) THEN + AAQQ = ( AAQQ / AAPP ) * TEMP1 + ELSE + AAQQ = ( AAQQ * TEMP1 ) / AAPP + END IF + TEMP1 = TEMP1 * SCALEM + CALL SLASCL( 'G', 0, 0, AAPP, TEMP1, M, N, A, LDA, IERR ) +* +* To undo scaling at the end of this procedure, multiply the +* computed singular values with USCAL2 / USCAL1. +* + USCAL1 = TEMP1 + USCAL2 = AAPP +* + IF ( L2KILL ) THEN +* L2KILL enforces computation of nonzero singular values in +* the restricted range of condition number of the initial A, +* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). + XSC = SQRT( SFMIN ) + ELSE + XSC = SMALL +* +* Now, if the condition number of A is too big, +* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, +* as a precaution measure, the full SVD is computed using SGESVJ +* with accumulated Jacobi rotations. This provides numerically +* more robust computation, at the cost of slightly increased run +* time. Depending on the concrete implementation of BLAS and LAPACK +* (i.e. how they behave in presence of extreme ill-conditioning) the +* implementor may decide to remove this switch. + IF ( ( AAQQ.LT.SQRT(SFMIN) ) .AND. LSVEC .AND. RSVEC ) THEN + JRACC = .TRUE. + END IF +* + END IF + IF ( AAQQ .LT. XSC ) THEN + DO 700 p = 1, N + IF ( SVA(p) .LT. XSC ) THEN + CALL SLASET( 'A', M, 1, ZERO, ZERO, A(1,p), LDA ) + SVA(p) = ZERO + END IF + 700 CONTINUE + END IF +* +* Preconditioning using QR factorization with pivoting +* + IF ( ROWPIV ) THEN +* Optional row permutation (Bjoerck row pivoting): +* A result by Cox and Higham shows that the Bjoerck's +* row pivoting combined with standard column pivoting +* has similar effect as Powell-Reid complete pivoting. +* The ell-infinity norms of A are made nonincreasing. + DO 1952 p = 1, M - 1 + q = ISAMAX( M-p+1, WORK(M+N+p), 1 ) + p - 1 + IWORK(2*N+p) = q + IF ( p .NE. q ) THEN + TEMP1 = WORK(M+N+p) + WORK(M+N+p) = WORK(M+N+q) + WORK(M+N+q) = TEMP1 + END IF + 1952 CONTINUE + CALL SLASWP( N, A, LDA, 1, M-1, IWORK(2*N+1), 1 ) + END IF +* +* End of the preparation phase (scaling, optional sorting and +* transposing, optional flushing of small columns). +* +* Preconditioning +* +* If the full SVD is needed, the right singular vectors are computed +* from a matrix equation, and for that we need theoretical analysis +* of the Businger-Golub pivoting. So we use SGEQP3 as the first RR QRF. +* In all other cases the first RR QRF can be chosen by other criteria +* (eg speed by replacing global with restricted window pivoting, such +* as in SGEQPX from TOMS # 782). Good results will be obtained using +* SGEQPX with properly (!) chosen numerical parameters. +* Any improvement of SGEQP3 improves overal performance of SGEJSV. +* +* A * P1 = Q1 * [ R1^t 0]^t: + DO 1963 p = 1, N +* .. all columns are free columns + IWORK(p) = 0 + 1963 CONTINUE + CALL SGEQP3( M,N,A,LDA, IWORK,WORK, WORK(N+1),LWORK-N, IERR ) +* +* The upper triangular matrix R1 from the first QRF is inspected for +* rank deficiency and possibilities for deflation, or possible +* ill-conditioning. Depending on the user specified flag L2RANK, +* the procedure explores possibilities to reduce the numerical +* rank by inspecting the computed upper triangular factor. If +* L2RANK or L2ABER are up, then SGEJSV will compute the SVD of +* A + dA, where ||dA|| <= f(M,N)*EPSLN. +* + NR = 1 + IF ( L2ABER ) THEN +* Standard absolute error bound suffices. All sigma_i with +* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an +* agressive enforcement of lower numerical rank by introducing a +* backward error of the order of N*EPSLN*||A||. + TEMP1 = SQRT(FLOAT(N))*EPSLN + DO 3001 p = 2, N + IF ( ABS(A(p,p)) .GE. (TEMP1*ABS(A(1,1))) ) THEN + NR = NR + 1 + ELSE + GO TO 3002 + END IF + 3001 CONTINUE + 3002 CONTINUE + ELSE IF ( L2RANK ) THEN +* .. similarly as above, only slightly more gentle (less agressive). +* Sudden drop on the diagonal of R1 is used as the criterion for +* close-to-rank-defficient. + TEMP1 = SQRT(SFMIN) + DO 3401 p = 2, N + IF ( ( ABS(A(p,p)) .LT. (EPSLN*ABS(A(p-1,p-1))) ) .OR. + & ( ABS(A(p,p)) .LT. SMALL ) .OR. + & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3402 + NR = NR + 1 + 3401 CONTINUE + 3402 CONTINUE +* + ELSE +* The goal is high relative accuracy. However, if the matrix +* has high scaled condition number the relative accuracy is in +* general not feasible. Later on, a condition number estimator +* will be deployed to estimate the scaled condition number. +* Here we just remove the underflowed part of the triangular +* factor. This prevents the situation in which the code is +* working hard to get the accuracy not warranted by the data. + TEMP1 = SQRT(SFMIN) + DO 3301 p = 2, N + IF ( ( ABS(A(p,p)) .LT. SMALL ) .OR. + & ( L2KILL .AND. (ABS(A(p,p)) .LT. TEMP1) ) ) GO TO 3302 + NR = NR + 1 + 3301 CONTINUE + 3302 CONTINUE +* + END IF +* + ALMORT = .FALSE. + IF ( NR .EQ. N ) THEN + MAXPRJ = ONE + DO 3051 p = 2, N + TEMP1 = ABS(A(p,p)) / SVA(IWORK(p)) + MAXPRJ = AMIN1( MAXPRJ, TEMP1 ) + 3051 CONTINUE + IF ( MAXPRJ**2 .GE. ONE - FLOAT(N)*EPSLN ) ALMORT = .TRUE. + END IF +* +* + SCONDA = - ONE + CONDR1 = - ONE + CONDR2 = - ONE +* + IF ( ERREST ) THEN + IF ( N .EQ. NR ) THEN + IF ( RSVEC ) THEN +* .. V is available as workspace + CALL SLACPY( 'U', N, N, A, LDA, V, LDV ) + DO 3053 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL SSCAL( p, ONE/TEMP1, V(1,p), 1 ) + 3053 CONTINUE + CALL SPOCON( 'U', N, V, LDV, ONE, TEMP1, + & WORK(N+1), IWORK(2*N+M+1), IERR ) + ELSE IF ( LSVEC ) THEN +* .. U is available as workspace + CALL SLACPY( 'U', N, N, A, LDA, U, LDU ) + DO 3054 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL SSCAL( p, ONE/TEMP1, U(1,p), 1 ) + 3054 CONTINUE + CALL SPOCON( 'U', N, U, LDU, ONE, TEMP1, + & WORK(N+1), IWORK(2*N+M+1), IERR ) + ELSE + CALL SLACPY( 'U', N, N, A, LDA, WORK(N+1), N ) + DO 3052 p = 1, N + TEMP1 = SVA(IWORK(p)) + CALL SSCAL( p, ONE/TEMP1, WORK(N+(p-1)*N+1), 1 ) + 3052 CONTINUE +* .. the columns of R are scaled to have unit Euclidean lengths. + CALL SPOCON( 'U', N, WORK(N+1), N, ONE, TEMP1, + & WORK(N+N*N+1), IWORK(2*N+M+1), IERR ) + END IF + SCONDA = ONE / SQRT(TEMP1) +* SCONDA is an estimate of SQRT(||(R^t * R)^(-1)||_1). +* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA + ELSE + SCONDA = - ONE + END IF + END IF +* + L2PERT = L2PERT .AND. ( ABS( A(1,1)/A(NR,NR) ) .GT. SQRT(BIG1) ) +* If there is no violent scaling, artificial perturbation is not needed. +* +* Phase 3: +* + IF ( .NOT. ( RSVEC .OR. LSVEC ) ) THEN +* +* Singular Values only +* +* .. transpose A(1:NR,1:N) + DO 1946 p = 1, MIN0( N-1, NR ) + CALL SCOPY( N-p, A(p,p+1), LDA, A(p+1,p), 1 ) + 1946 CONTINUE +* +* The following two DO-loops introduce small relative perturbation +* into the strict upper triangle of the lower triangular matrix. +* Small entries below the main diagonal are also changed. +* This modification is useful if the computing environment does not +* provide/allow FLUSH TO ZERO underflow, for it prevents many +* annoying denormalized numbers in case of strongly scaled matrices. +* The perturbation is structured so that it does not introduce any +* new perturbation of the singular values, and it does not destroy +* the job done by the preconditioner. +* The licence for this perturbation is in the variable L2PERT, which +* should be .FALSE. if FLUSH TO ZERO underflow is active. +* + IF ( .NOT. ALMORT ) THEN +* + IF ( L2PERT ) THEN +* XSC = SQRT(SMALL) + XSC = EPSLN / FLOAT(N) + DO 4947 q = 1, NR + TEMP1 = XSC*ABS(A(q,q)) + DO 4949 p = 1, N + IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) + & .OR. ( p .LT. q ) ) + & A(p,q) = SIGN( TEMP1, A(p,q) ) + 4949 CONTINUE + 4947 CONTINUE + ELSE + CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, A(1,2),LDA ) + END IF +* +* .. second preconditioning using the QR factorization +* + CALL SGEQRF( N,NR, A,LDA, WORK, WORK(N+1),LWORK-N, IERR ) +* +* .. and transpose upper to lower triangular + DO 1948 p = 1, NR - 1 + CALL SCOPY( NR-p, A(p,p+1), LDA, A(p+1,p), 1 ) + 1948 CONTINUE +* + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* +* .. again some perturbation (a "background noise") is added +* to drown denormals + IF ( L2PERT ) THEN +* XSC = SQRT(SMALL) + XSC = EPSLN / FLOAT(N) + DO 1947 q = 1, NR + TEMP1 = XSC*ABS(A(q,q)) + DO 1949 p = 1, NR + IF ( ( (p.GT.q) .AND. (ABS(A(p,q)).LE.TEMP1) ) + & .OR. ( p .LT. q ) ) + & A(p,q) = SIGN( TEMP1, A(p,q) ) + 1949 CONTINUE + 1947 CONTINUE + ELSE + CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, A(1,2), LDA ) + END IF +* +* .. and one-sided Jacobi rotations are started on a lower +* triangular matrix (plus perturbation which is ignored in +* the part which destroys triangular form (confusing?!)) +* + CALL SGESVJ( 'L', 'NoU', 'NoV', NR, NR, A, LDA, SVA, + & N, V, LDV, WORK, LWORK, INFO ) +* + SCALEM = WORK(1) + NUMRANK = NINT(WORK(2)) +* +* + ELSE IF ( RSVEC .AND. ( .NOT. LSVEC ) ) THEN +* +* -> Singular Values and Right Singular Vectors <- +* + IF ( ALMORT ) THEN +* +* .. in this case NR equals N + DO 1998 p = 1, NR + CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + 1998 CONTINUE + CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) +* + CALL SGESVJ( 'L','U','N', N, NR, V,LDV, SVA, NR, A,LDA, + & WORK, LWORK, INFO ) + SCALEM = WORK(1) + NUMRANK = NINT(WORK(2)) + + ELSE +* +* .. two more QR factorizations ( one QRF is not enough, two require +* accumulated product of Jacobi rotations, three are perfect ) +* + CALL SLASET( 'Lower', NR-1, NR-1, ZERO, ZERO, A(2,1), LDA ) + CALL SGELQF( NR, N, A, LDA, WORK, WORK(N+1), LWORK-N, IERR) + CALL SLACPY( 'Lower', NR, NR, A, LDA, V, LDV ) + CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) + CALL SGEQRF( NR, NR, V, LDV, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) + DO 8998 p = 1, NR + CALL SCOPY( NR-p+1, V(p,p), LDV, V(p,p), 1 ) + 8998 CONTINUE + CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) +* + CALL SGESVJ( 'Lower', 'U','N', NR, NR, V,LDV, SVA, NR, U, + & LDU, WORK(N+1), LWORK, INFO ) + SCALEM = WORK(N+1) + NUMRANK = NINT(WORK(N+2)) + IF ( NR .LT. N ) THEN + CALL SLASET( 'A',N-NR, NR, ZERO,ZERO, V(NR+1,1), LDV ) + CALL SLASET( 'A',NR, N-NR, ZERO,ZERO, V(1,NR+1), LDV ) + CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE, V(NR+1,NR+1), LDV ) + END IF +* + CALL SORMLQ( 'Left', 'Transpose', N, N, NR, A, LDA, WORK, + & V, LDV, WORK(N+1), LWORK-N, IERR ) +* + END IF +* + DO 8991 p = 1, N + CALL SCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) + 8991 CONTINUE + CALL SLACPY( 'All', N, N, A, LDA, V, LDV ) +* + IF ( TRANSP ) THEN + CALL SLACPY( 'All', N, N, V, LDV, U, LDU ) + END IF +* + ELSE IF ( LSVEC .AND. ( .NOT. RSVEC ) ) THEN +* +* -#- Singular Values and Left Singular Vectors -#- +* +* .. second preconditioning step to avoid need to accumulate +* Jacobi rotations in the Jacobi iterations. + DO 1965 p = 1, NR + CALL SCOPY( N-p+1, A(p,p), LDA, U(p,p), 1 ) + 1965 CONTINUE + CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) +* + CALL SGEQRF( N, NR, U, LDU, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) +* + DO 1967 p = 1, NR - 1 + CALL SCOPY( NR-p, U(p,p+1), LDU, U(p+1,p), 1 ) + 1967 CONTINUE + CALL SLASET( 'Upper', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) +* + CALL SGESVJ( 'Lower', 'U', 'N', NR,NR, U, LDU, SVA, NR, A, + & LDA, WORK(N+1), LWORK-N, INFO ) + SCALEM = WORK(N+1) + NUMRANK = NINT(WORK(N+2)) +* + IF ( NR .LT. M ) THEN + CALL SLASET( 'A', M-NR, NR,ZERO, ZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL SLASET( 'A',NR, N1-NR, ZERO, ZERO, U(1,NR+1), LDU ) + CALL SLASET( 'A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1), LDU ) + END IF + END IF +* + CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* + DO 1974 p = 1, N1 + XSC = ONE / SNRM2( M, U(1,p), 1 ) + CALL SSCAL( M, XSC, U(1,p), 1 ) + 1974 CONTINUE +* + IF ( TRANSP ) THEN + CALL SLACPY( 'All', N, N, U, LDU, V, LDV ) + END IF +* + ELSE +* +* -#- Full SVD -#- +* + IF ( .NOT. JRACC ) THEN +* + IF ( .NOT. ALMORT ) THEN +* +* Second Preconditioning Step (QRF [with pivoting]) +* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is +* equivalent to an LQF CALL. Since in many libraries the QRF +* seems to be better optimized than the LQF, we do explicit +* transpose and use the QRF. This is subject to changes in an +* optimized implementation of SGEJSV. +* + DO 1968 p = 1, NR + CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + 1968 CONTINUE +* +* .. the following two loops perturb small entries to avoid +* denormals in the second QR factorization, where they are +* as good as zeros. This is done to avoid painfully slow +* computation with denormals. The relative size of the perturbation +* is a parameter that can be changed by the implementer. +* This perturbation device will be obsolete on machines with +* properly implemented arithmetic. +* To switch it off, set L2PERT=.FALSE. To remove it from the +* code, remove the action under L2PERT=.TRUE., leave the ELSE part. +* The following two loops should be blocked and fused with the +* transposed copy above. +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 2969 q = 1, NR + TEMP1 = XSC*ABS( V(q,q) ) + DO 2968 p = 1, N + IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) + & .OR. ( p .LT. q ) ) + & V(p,q) = SIGN( TEMP1, V(p,q) ) + IF ( p. LT. q ) V(p,q) = - V(p,q) + 2968 CONTINUE + 2969 CONTINUE + ELSE + CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) + END IF +* +* Estimate the row scaled condition number of R1 +* (If R1 is rectangular, N > NR, then the condition number +* of the leading NR x NR submatrix is estimated.) +* + CALL SLACPY( 'L', NR, NR, V, LDV, WORK(2*N+1), NR ) + DO 3950 p = 1, NR + TEMP1 = SNRM2(NR-p+1,WORK(2*N+(p-1)*NR+p),1) + CALL SSCAL(NR-p+1,ONE/TEMP1,WORK(2*N+(p-1)*NR+p),1) + 3950 CONTINUE + CALL SPOCON('Lower',NR,WORK(2*N+1),NR,ONE,TEMP1, + & WORK(2*N+NR*NR+1),IWORK(M+2*N+1),IERR) + CONDR1 = ONE / SQRT(TEMP1) +* .. here need a second oppinion on the condition number +* .. then assume worst case scenario +* R1 is OK for inverse <=> CONDR1 .LT. FLOAT(N) +* more conservative <=> CONDR1 .LT. SQRT(FLOAT(N)) +* + COND_OK = SQRT(FLOAT(NR)) +*[TP] COND_OK is a tuning parameter. + + IF ( CONDR1 .LT. COND_OK ) THEN +* .. the second QRF without pivoting. Note: in an optimized +* implementation, this QRF should be implemented as the QRF +* of a lower triangular matrix. +* R1^t = Q2 * R2 + CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL)/EPSLN + DO 3959 p = 2, NR + DO 3958 q = 1, p - 1 + TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q))) + IF ( ABS(V(q,p)) .LE. TEMP1 ) + & V(q,p) = SIGN( TEMP1, V(q,p) ) + 3958 CONTINUE + 3959 CONTINUE + END IF +* + IF ( NR .NE. N ) +* .. save ... + & CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N ) +* +* .. this transposed copy should be better than naive + DO 1969 p = 1, NR - 1 + CALL SCOPY( NR-p, V(p,p+1), LDV, V(p+1,p), 1 ) + 1969 CONTINUE +* + CONDR2 = CONDR1 +* + ELSE +* +* .. ill-conditioned case: second QRF with pivoting +* Note that windowed pivoting would be equaly good +* numerically, and more run-time efficient. So, in +* an optimal implementation, the next call to SGEQP3 +* should be replaced with eg. CALL SGEQPX (ACM TOMS #782) +* with properly (carefully) chosen parameters. +* +* R1^t * P2 = Q2 * R2 + DO 3003 p = 1, NR + IWORK(N+p) = 0 + 3003 CONTINUE + CALL SGEQP3( N, NR, V, LDV, IWORK(N+1), WORK(N+1), + & WORK(2*N+1), LWORK-2*N, IERR ) +** CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), +** & LWORK-2*N, IERR ) + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 3969 p = 2, NR + DO 3968 q = 1, p - 1 + TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q))) + IF ( ABS(V(q,p)) .LE. TEMP1 ) + & V(q,p) = SIGN( TEMP1, V(q,p) ) + 3968 CONTINUE + 3969 CONTINUE + END IF +* + CALL SLACPY( 'A', N, NR, V, LDV, WORK(2*N+1), N ) +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 8970 p = 2, NR + DO 8971 q = 1, p - 1 + TEMP1 = XSC * AMIN1(ABS(V(p,p)),ABS(V(q,q))) + V(p,q) = - SIGN( TEMP1, V(q,p) ) + 8971 CONTINUE + 8970 CONTINUE + ELSE + CALL SLASET( 'L',NR-1,NR-1,ZERO,ZERO,V(2,1),LDV ) + END IF +* Now, compute R2 = L3 * Q3, the LQ factorization. + CALL SGELQF( NR, NR, V, LDV, WORK(2*N+N*NR+1), + & WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, IERR ) +* .. and estimate the condition number + CALL SLACPY( 'L',NR,NR,V,LDV,WORK(2*N+N*NR+NR+1),NR ) + DO 4950 p = 1, NR + TEMP1 = SNRM2( p, WORK(2*N+N*NR+NR+p), NR ) + CALL SSCAL( p, ONE/TEMP1, WORK(2*N+N*NR+NR+p), NR ) + 4950 CONTINUE + CALL SPOCON( 'L',NR,WORK(2*N+N*NR+NR+1),NR,ONE,TEMP1, + & WORK(2*N+N*NR+NR+NR*NR+1),IWORK(M+2*N+1),IERR ) + CONDR2 = ONE / SQRT(TEMP1) +* + IF ( CONDR2 .GE. COND_OK ) THEN +* .. save the Householder vectors used for Q3 +* (this overwrittes the copy of R2, as it will not be +* needed in this branch, but it does not overwritte the +* Huseholder vectors of Q2.). + CALL SLACPY( 'U', NR, NR, V, LDV, WORK(2*N+1), N ) +* .. and the rest of the information on Q3 is in +* WORK(2*N+N*NR+1:2*N+N*NR+N) + END IF +* + END IF +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 4968 q = 2, NR + TEMP1 = XSC * V(q,q) + DO 4969 p = 1, q - 1 +* V(p,q) = - SIGN( TEMP1, V(q,p) ) + V(p,q) = - SIGN( TEMP1, V(p,q) ) + 4969 CONTINUE + 4968 CONTINUE + ELSE + CALL SLASET( 'U', NR-1,NR-1, ZERO,ZERO, V(1,2), LDV ) + END IF +* +* Second preconditioning finished; continue with Jacobi SVD +* The input matrix is lower trinagular. +* +* Recover the right singular vectors as solution of a well +* conditioned triangular matrix equation. +* + IF ( CONDR1 .LT. COND_OK ) THEN +* + CALL SGESVJ( 'L','U','N',NR,NR,V,LDV,SVA,NR,U, + & LDU,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,INFO ) + SCALEM = WORK(2*N+N*NR+NR+1) + NUMRANK = NINT(WORK(2*N+N*NR+NR+2)) + DO 3970 p = 1, NR + CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL SSCAL( NR, SVA(p), V(1,p), 1 ) + 3970 CONTINUE + +* .. pick the right matrix equation and solve it +* + IF ( NR. EQ. N ) THEN +* :)) .. best case, R1 is inverted. The solution of this matrix +* equation is Q2*V2 = the product of the Jacobi rotations +* used in SGESVJ, premultiplied with the orthogonal matrix +* from the second QR factorization. + CALL STRSM( 'L','U','N','N', NR,NR,ONE, A,LDA, V,LDV ) + ELSE +* .. R1 is well conditioned, but non-square. Transpose(R2) +* is inverted to get the product of the Jacobi rotations +* used in SGESVJ. The Q-factor from the second QR +* factorization is then built in explicitly. + CALL STRSM('L','U','T','N',NR,NR,ONE,WORK(2*N+1), + & N,V,LDV) + IF ( NR .LT. N ) THEN + CALL SLASET('A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV) + CALL SLASET('A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV) + CALL SLASET('A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV) + END IF + CALL SORMQR('L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR) + END IF +* + ELSE IF ( CONDR2 .LT. COND_OK ) THEN +* +* :) .. the input matrix A is very likely a relative of +* the Kahan matrix :) +* The matrix R2 is inverted. The solution of the matrix equation +* is Q3^T*V3 = the product of the Jacobi rotations (appplied to +* the lower triangular L3 from the LQ factorization of +* R2=L3*Q3), pre-multiplied with the transposed Q3. + CALL SGESVJ( 'L', 'U', 'N', NR, NR, V, LDV, SVA, NR, U, + & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO ) + SCALEM = WORK(2*N+N*NR+NR+1) + NUMRANK = NINT(WORK(2*N+N*NR+NR+2)) + DO 3870 p = 1, NR + CALL SCOPY( NR, V(1,p), 1, U(1,p), 1 ) + CALL SSCAL( NR, SVA(p), U(1,p), 1 ) + 3870 CONTINUE + CALL STRSM('L','U','N','N',NR,NR,ONE,WORK(2*N+1),N,U,LDU) +* .. apply the permutation from the second QR factorization + DO 873 q = 1, NR + DO 872 p = 1, NR + WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 872 CONTINUE + DO 874 p = 1, NR + U(p,q) = WORK(2*N+N*NR+NR+p) + 874 CONTINUE + 873 CONTINUE + IF ( NR .LT. N ) THEN + CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) + CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) + CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) + END IF + CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) + ELSE +* Last line of defense. +* #:( This is a rather pathological case: no scaled condition +* improvement after two pivoted QR factorizations. Other +* possibility is that the rank revealing QR factorization +* or the condition estimator has failed, or the COND_OK +* is set very close to ONE (which is unnecessary). Normally, +* this branch should never be executed, but in rare cases of +* failure of the RRQR or condition estimator, the last line of +* defense ensures that SGEJSV completes the task. +* Compute the full SVD of L3 using SGESVJ with explicit +* accumulation of Jacobi rotations. + CALL SGESVJ( 'L', 'U', 'V', NR, NR, V, LDV, SVA, NR, U, + & LDU, WORK(2*N+N*NR+NR+1), LWORK-2*N-N*NR-NR, INFO ) + SCALEM = WORK(2*N+N*NR+NR+1) + NUMRANK = NINT(WORK(2*N+N*NR+NR+2)) + IF ( NR .LT. N ) THEN + CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) + CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) + CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) + END IF + CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* + CALL SORMLQ( 'L', 'T', NR, NR, NR, WORK(2*N+1), N, + & WORK(2*N+N*NR+1), U, LDU, WORK(2*N+N*NR+NR+1), + & LWORK-2*N-N*NR-NR, IERR ) + DO 773 q = 1, NR + DO 772 p = 1, NR + WORK(2*N+N*NR+NR+IWORK(N+p)) = U(p,q) + 772 CONTINUE + DO 774 p = 1, NR + U(p,q) = WORK(2*N+N*NR+NR+p) + 774 CONTINUE + 773 CONTINUE +* + END IF +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = SQRT(FLOAT(N)) * EPSLN + DO 1972 q = 1, N + DO 972 p = 1, N + WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 972 CONTINUE + DO 973 p = 1, N + V(p,q) = WORK(2*N+N*NR+NR+p) + 973 CONTINUE + XSC = ONE / SNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL SSCAL( N, XSC, V(1,q), 1 ) + 1972 CONTINUE +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). + IF ( NR .LT. M ) THEN + CALL SLASET( 'A', M-NR, NR, ZERO, ZERO, U(NR+1,1), LDU ) + IF ( NR .LT. N1 ) THEN + CALL SLASET('A',NR,N1-NR,ZERO,ZERO,U(1,NR+1),LDU) + CALL SLASET('A',M-NR,N1-NR,ZERO,ONE,U(NR+1,NR+1),LDU) + END IF + END IF +* +* The Q matrix from the first QRF is built into the left singular +* matrix U. This applies to all cases. +* + CALL SORMQR( 'Left', 'No_Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) + +* The columns of U are normalized. The cost is O(M*N) flops. + TEMP1 = SQRT(FLOAT(M)) * EPSLN + DO 1973 p = 1, NR + XSC = ONE / SNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL SSCAL( M, XSC, U(1,p), 1 ) + 1973 CONTINUE +* +* If the initial QRF is computed with row pivoting, the left +* singular vectors must be adjusted. +* + IF ( ROWPIV ) + & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* + ELSE +* +* .. the initial matrix A has almost orthogonal columns and +* the second QRF is not needed +* + CALL SLACPY( 'Upper', N, N, A, LDA, WORK(N+1), N ) + IF ( L2PERT ) THEN + XSC = SQRT(SMALL) + DO 5970 p = 2, N + TEMP1 = XSC * WORK( N + (p-1)*N + p ) + DO 5971 q = 1, p - 1 + WORK(N+(q-1)*N+p)=-SIGN(TEMP1,WORK(N+(p-1)*N+q)) + 5971 CONTINUE + 5970 CONTINUE + ELSE + CALL SLASET( 'Lower',N-1,N-1,ZERO,ZERO,WORK(N+2),N ) + END IF +* + CALL SGESVJ( 'Upper', 'U', 'N', N, N, WORK(N+1), N, SVA, + & N, U, LDU, WORK(N+N*N+1), LWORK-N-N*N, INFO ) +* + SCALEM = WORK(N+N*N+1) + NUMRANK = NINT(WORK(N+N*N+2)) + DO 6970 p = 1, N + CALL SCOPY( N, WORK(N+(p-1)*N+1), 1, U(1,p), 1 ) + CALL SSCAL( N, SVA(p), WORK(N+(p-1)*N+1), 1 ) + 6970 CONTINUE +* + CALL STRSM( 'Left', 'Upper', 'NoTrans', 'No UD', N, N, + & ONE, A, LDA, WORK(N+1), N ) + DO 6972 p = 1, N + CALL SCOPY( N, WORK(N+p), N, V(IWORK(p),1), LDV ) + 6972 CONTINUE + TEMP1 = SQRT(FLOAT(N))*EPSLN + DO 6971 p = 1, N + XSC = ONE / SNRM2( N, V(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL SSCAL( N, XSC, V(1,p), 1 ) + 6971 CONTINUE +* +* Assemble the left singular vector matrix U (M x N). +* + IF ( N .LT. M ) THEN + CALL SLASET( 'A', M-N, N, ZERO, ZERO, U(NR+1,1), LDU ) + IF ( N .LT. N1 ) THEN + CALL SLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU ) + CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(NR+1,N+1),LDU ) + END IF + END IF + CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) + TEMP1 = SQRT(FLOAT(M))*EPSLN + DO 6973 p = 1, N1 + XSC = ONE / SNRM2( M, U(1,p), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL SSCAL( M, XSC, U(1,p), 1 ) + 6973 CONTINUE +* + IF ( ROWPIV ) + & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* + END IF +* +* end of the >> almost orthogonal case << in the full SVD +* + ELSE +* +* This branch deploys a preconditioned Jacobi SVD with explicitly +* accumulated rotations. It is included as optional, mainly for +* experimental purposes. It does perfom well, and can also be used. +* In this implementation, this branch will be automatically activated +* if the condition number sigma_max(A) / sigma_min(A) is predicted +* to be greater than the overflow threshold. This is because the +* a posteriori computation of the singular vectors assumes robust +* implementation of BLAS and some LAPACK procedures, capable of working +* in presence of extreme values. Since that is not always the case, ... +* + DO 7968 p = 1, NR + CALL SCOPY( N-p+1, A(p,p), LDA, V(p,p), 1 ) + 7968 CONTINUE +* + IF ( L2PERT ) THEN + XSC = SQRT(SMALL/EPSLN) + DO 5969 q = 1, NR + TEMP1 = XSC*ABS( V(q,q) ) + DO 5968 p = 1, N + IF ( ( p .GT. q ) .AND. ( ABS(V(p,q)) .LE. TEMP1 ) + & .OR. ( p .LT. q ) ) + & V(p,q) = SIGN( TEMP1, V(p,q) ) + IF ( p. LT. q ) V(p,q) = - V(p,q) + 5968 CONTINUE + 5969 CONTINUE + ELSE + CALL SLASET( 'U', NR-1, NR-1, ZERO, ZERO, V(1,2), LDV ) + END IF + + CALL SGEQRF( N, NR, V, LDV, WORK(N+1), WORK(2*N+1), + & LWORK-2*N, IERR ) + CALL SLACPY( 'L', N, NR, V, LDV, WORK(2*N+1), N ) +* + DO 7969 p = 1, NR + CALL SCOPY( NR-p+1, V(p,p), LDV, U(p,p), 1 ) + 7969 CONTINUE + + IF ( L2PERT ) THEN + XSC = SQRT(SMALL/EPSLN) + DO 9970 q = 2, NR + DO 9971 p = 1, q - 1 + TEMP1 = XSC * AMIN1(ABS(U(p,p)),ABS(U(q,q))) + U(p,q) = - SIGN( TEMP1, U(q,p) ) + 9971 CONTINUE + 9970 CONTINUE + ELSE + CALL SLASET('U', NR-1, NR-1, ZERO, ZERO, U(1,2), LDU ) + END IF + + CALL SGESVJ( 'L', 'U', 'V', NR, NR, U, LDU, SVA, + & N, V, LDV, WORK(2*N+N*NR+1), LWORK-2*N-N*NR, INFO ) + SCALEM = WORK(2*N+N*NR+1) + NUMRANK = NINT(WORK(2*N+N*NR+2)) + + IF ( NR .LT. N ) THEN + CALL SLASET( 'A',N-NR,NR,ZERO,ZERO,V(NR+1,1),LDV ) + CALL SLASET( 'A',NR,N-NR,ZERO,ZERO,V(1,NR+1),LDV ) + CALL SLASET( 'A',N-NR,N-NR,ZERO,ONE,V(NR+1,NR+1),LDV ) + END IF + + CALL SORMQR( 'L','N',N,N,NR,WORK(2*N+1),N,WORK(N+1), + & V,LDV,WORK(2*N+N*NR+NR+1),LWORK-2*N-N*NR-NR,IERR ) +* +* Permute the rows of V using the (column) permutation from the +* first QRF. Also, scale the columns to make them unit in +* Euclidean norm. This applies to all cases. +* + TEMP1 = SQRT(FLOAT(N)) * EPSLN + DO 7972 q = 1, N + DO 8972 p = 1, N + WORK(2*N+N*NR+NR+IWORK(p)) = V(p,q) + 8972 CONTINUE + DO 8973 p = 1, N + V(p,q) = WORK(2*N+N*NR+NR+p) + 8973 CONTINUE + XSC = ONE / SNRM2( N, V(1,q), 1 ) + IF ( (XSC .LT. (ONE-TEMP1)) .OR. (XSC .GT. (ONE+TEMP1)) ) + & CALL SSCAL( N, XSC, V(1,q), 1 ) + 7972 CONTINUE +* +* At this moment, V contains the right singular vectors of A. +* Next, assemble the left singular vector matrix U (M x N). +* + IF ( N .LT. M ) THEN + CALL SLASET( 'A', M-N, N, ZERO, ZERO, U(NR+1,1), LDU ) + IF ( N .LT. N1 ) THEN + CALL SLASET( 'A',N, N1-N, ZERO, ZERO, U(1,N+1),LDU ) + CALL SLASET( 'A',M-N,N1-N, ZERO, ONE,U(NR+1,N+1),LDU ) + END IF + END IF +* + CALL SORMQR( 'Left', 'No Tr', M, N1, N, A, LDA, WORK, U, + & LDU, WORK(N+1), LWORK-N, IERR ) +* + IF ( ROWPIV ) + & CALL SLASWP( N1, U, LDU, 1, M-1, IWORK(2*N+1), -1 ) +* +* + END IF + IF ( TRANSP ) THEN +* .. swap U and V because the procedure worked on A^t + DO 6974 p = 1, N + CALL SSWAP( N, U(1,p), 1, V(1,p), 1 ) + 6974 CONTINUE + END IF +* + END IF +* end of the full SVD +* +* Undo scaling, if necessary (and possible) +* + IF ( USCAL2 .LE. (BIG/SVA(1))*USCAL1 ) THEN + CALL SLASCL( 'G', 0, 0, USCAL1, USCAL2, NR, 1, SVA, N, IERR ) + USCAL1 = ONE + USCAL2 = ONE + END IF +* + IF ( NR .LT. N ) THEN + DO 3004 p = NR+1, N + SVA(p) = ZERO + 3004 CONTINUE + END IF +* + WORK(1) = USCAL2 * SCALEM + WORK(2) = USCAL1 + IF ( ERREST ) WORK(3) = SCONDA + IF ( LSVEC .AND. RSVEC ) THEN + WORK(4) = CONDR1 + WORK(5) = CONDR2 + END IF + IF ( L2TRAN ) THEN + WORK(6) = ENTRA + WORK(7) = ENTRAT + END IF +* + IWORK(1) = NR + IWORK(2) = NUMRANK + IWORK(3) = WARNING +* + RETURN +* .. +* .. END OF SGEJSV +* .. + END +* diff --git a/SRC/sgelq2.f b/SRC/sgelq2.f index ba7a7850..a6245a72 100644 --- a/SRC/sgelq2.f +++ b/SRC/sgelq2.f @@ -1,6 +1,6 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgelqf.f b/SRC/sgelqf.f index c197524a..b765bb04 100644 --- a/SRC/sgelqf.f +++ b/SRC/sgelqf.f @@ -1,6 +1,6 @@ SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgels.f b/SRC/sgels.f index c5afc362..52b0d263 100644 --- a/SRC/sgels.f +++ b/SRC/sgels.f @@ -1,7 +1,7 @@ SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgelsd.f b/SRC/sgelsd.f index fb27c506..ead2236c 100644 --- a/SRC/sgelsd.f +++ b/SRC/sgelsd.f @@ -1,7 +1,7 @@ SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, $ RANK, WORK, LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgelss.f b/SRC/sgelss.f index 33e5977c..5cef5e10 100644 --- a/SRC/sgelss.f +++ b/SRC/sgelss.f @@ -1,7 +1,7 @@ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgelsx.f b/SRC/sgelsx.f index 9125bdc0..2bb36c39 100644 --- a/SRC/sgelsx.f +++ b/SRC/sgelsx.f @@ -1,7 +1,7 @@ SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgelsy.f b/SRC/sgelsy.f index a7d3d8a7..a2025cfe 100644 --- a/SRC/sgelsy.f +++ b/SRC/sgelsy.f @@ -1,7 +1,7 @@ SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeql2.f b/SRC/sgeql2.f index 187980de..c1460fcb 100644 --- a/SRC/sgeql2.f +++ b/SRC/sgeql2.f @@ -1,6 +1,6 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeqlf.f b/SRC/sgeqlf.f index 347fa911..d72acac3 100644 --- a/SRC/sgeqlf.f +++ b/SRC/sgeqlf.f @@ -1,6 +1,6 @@ SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeqp3.f b/SRC/sgeqp3.f index 0c0d9b87..bb28dc3d 100644 --- a/SRC/sgeqp3.f +++ b/SRC/sgeqp3.f @@ -1,6 +1,6 @@ SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeqpf.f b/SRC/sgeqpf.f index f0c9afa8..90002af4 100644 --- a/SRC/sgeqpf.f +++ b/SRC/sgeqpf.f @@ -1,6 +1,6 @@ SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO ) * -* -- LAPACK deprecated driver routine (version 3.1) -- +* -- LAPACK deprecated driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeqr2.f b/SRC/sgeqr2.f index 6c1ad935..1910c8f7 100644 --- a/SRC/sgeqr2.f +++ b/SRC/sgeqr2.f @@ -1,6 +1,6 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgeqrf.f b/SRC/sgeqrf.f index ae527007..a2331c62 100644 --- a/SRC/sgeqrf.f +++ b/SRC/sgeqrf.f @@ -1,6 +1,6 @@ SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgerfs.f b/SRC/sgerfs.f index 29014df4..fbccf782 100644 --- a/SRC/sgerfs.f +++ b/SRC/sgerfs.f @@ -1,7 +1,7 @@ SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgerfsx.f b/SRC/sgerfsx.f new file mode 100644 index 00000000..7933c7e5 --- /dev/null +++ b/SRC/sgerfsx.f @@ -0,0 +1,605 @@ + SUBROUTINE SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ), WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SGERFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The original N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) REAL array, dimension (LDAF,N) +* The factors L and U from the factorization A = P*L*U +* as computed by SGETRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from SGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) REAL array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) REAL array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SGECON, SLA_GERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, SLANGE, SLA_GERCOND + REAL SLAMCH, SLANGE, SLA_GERCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = SLANGE( NORM, N, N, A, LDA, WORK ) + CALL SGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + IF ( NOTRAN ) THEN + CALL SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), WORK(1), WORK(2*N+1), + $ WORK(1), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + ELSE + CALL SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), WORK(1), WORK(2*N+1), + $ WORK(1), RCOND, ITHRESH, RTHRESH, UNSTABLE_THRESH, + $ IGNORE_CWISE, INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = SLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ -1, C, INFO, WORK, IWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = SLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ -1, R, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = SLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ 0, R, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = SLA_GERCOND( TRANS, N, A, LDA, AF, LDAF, + $ IPIV, 1, X(1,J), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF +* + RETURN +* +* End of SGERFSX +* + END diff --git a/SRC/sgerq2.f b/SRC/sgerq2.f index e07936a1..ed96b3ca 100644 --- a/SRC/sgerq2.f +++ b/SRC/sgerq2.f @@ -1,6 +1,6 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgerqf.f b/SRC/sgerqf.f index fb9b7a2d..bb5c0c27 100644 --- a/SRC/sgerqf.f +++ b/SRC/sgerqf.f @@ -1,6 +1,6 @@ SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgesc2.f b/SRC/sgesc2.f index de62e77d..50a71f66 100644 --- a/SRC/sgesc2.f +++ b/SRC/sgesc2.f @@ -1,6 +1,6 @@ SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgesdd.f b/SRC/sgesdd.f index de3683d8..994fbb95 100644 --- a/SRC/sgesdd.f +++ b/SRC/sgesdd.f @@ -1,7 +1,7 @@ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgesv.f b/SRC/sgesv.f index acb2f912..5dc32bf2 100644 --- a/SRC/sgesv.f +++ b/SRC/sgesv.f @@ -1,6 +1,6 @@ SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgesvd.f b/SRC/sgesvd.f index 6217d039..68a8aa0f 100644 --- a/SRC/sgesvd.f +++ b/SRC/sgesvd.f @@ -1,7 +1,7 @@ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgesvj.f b/SRC/sgesvj.f new file mode 100644 index 00000000..71193ee1 --- /dev/null +++ b/SRC/sgesvj.f @@ -0,0 +1,1350 @@ + SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, + & MV, V, LDV, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* -#- Scalar Arguments -#- +* + IMPLICIT NONE + INTEGER INFO, LDA, LDV, LWORK, M, MV, N + CHARACTER*1 JOBA, JOBU, JOBV +* +* -#- Array Arguments -#- +* + REAL A( LDA, * ), SVA( N ), V( LDV, * ), WORK( LWORK ) +* .. +* +* Purpose +* ~~~~~~~ +* SGESVJ computes the singular value decomposition (SVD) of a real +* M-by-N matrix A, where M >= N. The SVD of A is written as +* [++] [xx] [x0] [xx] +* A = U * SIGMA * V^t, [++] = [xx] * [ox] * [xx] +* [++] [xx] +* where SIGMA is an N-by-N diagonal matrix, U is an M-by-N orthonormal +* matrix, and V is an N-by-N orthogonal matrix. The diagonal elements +* of SIGMA are the singular values of A. The columns of U and V are the +* left and the right singular vectors of A, respectively. +* +* Further Details +* ~~~~~~~~~~~~~~~ +* The orthogonal N-by-N matrix V is obtained as a product of Jacobi plane +* rotations. The rotations are implemented as fast scaled rotations of +* Anda and Park [1]. In the case of underflow of the Jacobi angle, a +* modified Jacobi transformation of Drmac [4] is used. Pivot strategy uses +* column interchanges of de Rijk [2]. The relative accuracy of the computed +* singular values and the accuracy of the computed singular vectors (in +* angle metric) is as guaranteed by the theory of Demmel and Veselic [3]. +* The condition number that determines the accuracy in the full rank case +* is essentially min_{D=diag} kappa(A*D), where kappa(.) is the +* spectral condition number. The best performance of this Jacobi SVD +* procedure is achieved if used in an accelerated version of Drmac and +* Veselic [5,6], and it is the kernel routine in the SIGMA library [7]. +* Some tunning parameters (marked with [TP]) are available for the +* implementer. +* The computational range for the nonzero singular values is the machine +* number interval ( UNDERFLOW , OVERFLOW ). In extreme cases, even +* denormalized singular values can be computed with the corresponding +* gradual loss of accurate digits. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* References +* ~~~~~~~~~~ +* [1] A. A. Anda and H. Park: Fast plane rotations with dynamic scaling. +* SIAM J. matrix Anal. Appl., Vol. 15 (1994), pp. 162-174. +* [2] P. P. M. De Rijk: A one-sided Jacobi algorithm for computing the +* singular value decomposition on a vector computer. +* SIAM J. Sci. Stat. Comp., Vol. 10 (1998), pp. 359-371. +* [3] J. Demmel and K. Veselic: Jacobi method is more accurate than QR. +* [4] Z. Drmac: Implementation of Jacobi rotations for accurate singular +* value computation in floating point arithmetic. +* SIAM J. Sci. Comp., Vol. 18 (1997), pp. 1200-1222. +* [5] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. +* LAPACK Working note 169. +* [6] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. +* SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. +* LAPACK Working note 170. +* [7] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, +* QSVD, (H,K)-SVD computations. +* Department of Mathematics, University of Zagreb, 2008. +* +* Bugs, Examples and Comments +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Please report all bugs and send interesting test examples and comments to +* drmac@math.hr. Thank you. +* +* Arguments +* ~~~~~~~~~ +* +* JOBA (input) CHARACTER* 1 +* Specifies the structure of A. +* = 'L': The input matrix A is lower triangular; +* = 'U': The input matrix A is upper triangular; +* = 'G': The input matrix A is general M-by-N matrix, M >= N. +* +* JOBU (input) CHARACTER*1 +* Specifies whether to compute the left singular vectors +* (columns of U): +* +* = 'U': The left singular vectors corresponding to the nonzero +* singular values are computed and returned in the leading +* columns of A. See more details in the description of A. +* The default numerical orthogonality threshold is set to +* approximately TOL=CTOL*EPS, CTOL=SQRT(M), EPS=SLAMCH('E'). +* = 'C': Analogous to JOBU='U', except that user can control the +* level of numerical orthogonality of the computed left +* singular vectors. TOL can be set to TOL = CTOL*EPS, where +* CTOL is given on input in the array WORK. +* No CTOL smaller than ONE is allowed. CTOL greater +* than 1 / EPS is meaningless. The option 'C' +* can be used if M*EPS is satisfactory orthogonality +* of the computed left singular vectors, so CTOL=M could +* save few sweeps of Jacobi rotations. +* See the descriptions of A and WORK(1). +* = 'N': The matrix U is not computed. However, see the +* description of A. +* +* JOBV (input) CHARACTER*1 +* Specifies whether to compute the right singular vectors, that +* is, the matrix V: +* = 'V' : the matrix V is computed and returned in the array V +* = 'A' : the Jacobi rotations are applied to the MV-by-N +* array V. In other words, the right singular vector +* matrix V is not computed explicitly; instead it is +* applied to an MV-by-N matrix initially stored in the +* first MV rows of V. +* = 'N' : the matrix V is not computed and the array V is not +* referenced +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. +* M >= N >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, the M-by-N matrix A. +* On exit, +* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C': +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If INFO .EQ. 0, +* ~~~~~~~~~~~~~~~ +* RANKA orthonormal columns of U are returned in the +* leading RANKA columns of the array A. Here RANKA <= N +* is the number of computed singular values of A that are +* above the underflow threshold SLAMCH('S'). The singular +* vectors corresponding to underflowed or zero singular +* values are not computed. The value of RANKA is returned +* in the array WORK as RANKA=NINT(WORK(2)). Also see the +* descriptions of SVA and WORK. The computed columns of U +* are mutually numerically orthogonal up to approximately +* TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'), +* see the description of JOBU. +* If INFO .GT. 0, +* ~~~~~~~~~~~~~~~ +* the procedure SGESVJ did not converge in the given number +* of iterations (sweeps). In that case, the computed +* columns of U may not be orthogonal up to TOL. The output +* U (stored in A), SIGMA (given by the computed singular +* values in SVA(1:N)) and V is still a decomposition of the +* input matrix A in the sense that the residual +* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small. +* +* If JOBU .EQ. 'N': +* ~~~~~~~~~~~~~~~~~ +* If INFO .EQ. 0 +* ~~~~~~~~~~~~~~ +* Note that the left singular vectors are 'for free' in the +* one-sided Jacobi SVD algorithm. However, if only the +* singular values are needed, the level of numerical +* orthogonality of U is not an issue and iterations are +* stopped when the columns of the iterated matrix are +* numerically orthogonal up to approximately M*EPS. Thus, +* on exit, A contains the columns of U scaled with the +* corresponding singular values. +* If INFO .GT. 0, +* ~~~~~~~~~~~~~~~ +* the procedure SGESVJ did not converge in the given number +* of iterations (sweeps). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* SVA (workspace/output) REAL array, dimension (N) +* On exit, +* If INFO .EQ. 0, +* ~~~~~~~~~~~~~~~ +* depending on the value SCALE = WORK(1), we have: +* If SCALE .EQ. ONE: +* ~~~~~~~~~~~~~~~~~~ +* SVA(1:N) contains the computed singular values of A. +* During the computation SVA contains the Euclidean column +* norms of the iterated matrices in the array A. +* If SCALE .NE. ONE: +* ~~~~~~~~~~~~~~~~~~ +* The singular values of A are SCALE*SVA(1:N), and this +* factored representation is due to the fact that some of the +* singular values of A might underflow or overflow. +* +* If INFO .GT. 0, +* ~~~~~~~~~~~~~~~ +* the procedure SGESVJ did not converge in the given number of +* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate. +* +* MV (input) INTEGER +* If JOBV .EQ. 'A', then the product of Jacobi rotations in SGESVJ +* is applied to the first MV rows of V. See the description of JOBV. +* +* V (input/output) REAL array, dimension (LDV,N) +* If JOBV = 'V', then V contains on exit the N-by-N matrix of +* the right singular vectors; +* If JOBV = 'A', then V contains the product of the computed right +* singular vector matrix and the initial matrix in +* the array V. +* If JOBV = 'N', then V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV .GE. 1. +* If JOBV .EQ. 'V', then LDV .GE. max(1,N). +* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) . +* +* WORK (input/workspace/output) REAL array, dimension max(4,M+N). +* On entry, +* If JOBU .EQ. 'C', +* ~~~~~~~~~~~~~~~~~ +* WORK(1) = CTOL, where CTOL defines the threshold for convergence. +* The process stops if all columns of A are mutually +* orthogonal up to CTOL*EPS, EPS=SLAMCH('E'). +* It is required that CTOL >= ONE, i.e. it is not +* allowed to force the routine to obtain orthogonality +* below EPSILON. +* On exit, +* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N) +* are the computed singular vcalues of A. +* (See description of SVA().) +* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero +* singular values. +* WORK(3) = NINT(WORK(3)) is the number of the computed singular +* values that are larger than the underflow threshold. +* WORK(4) = NINT(WORK(4)) is the number of sweeps of Jacobi +* rotations needed for numerical convergence. +* WORK(5) = max_{i.NE.j} |COS(A(:,i),A(:,j))| in the last sweep. +* This is useful information in cases when SGESVJ did +* not converge, as it can be used to estimate whether +* the output is stil useful and for post festum analysis. +* WORK(6) = the largest absolute value over all sines of the +* Jacobi rotation angles in the last sweep. It can be +* useful for a post festum analysis. +* +* LWORK length of WORK, WORK >= MAX(6,M+N) +* +* INFO (output) INTEGER +* = 0 : successful exit. +* < 0 : if INFO = -i, then the i-th argument had an illegal value +* > 0 : SGESVJ did not converge in the maximal allowed number (30) +* of sweeps. The output may still be useful. See the +* description of WORK. +* +* Local Parameters +* + REAL ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 ) + INTEGER NSWEEP + PARAMETER ( NSWEEP = 30 ) +* +* Local Scalars +* + REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, + & BIG, BIGTHETA, CS, CTOL, EPSILON, LARGE, + & MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL, + & SCALE, SFMIN, SMALL, SN, T, TEMP1, + & THETA, THSIGN, TOL + INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, + & IJBLSK, ir1, ISWROT, jbc, jgl, KBL, + & LKAHEAD, MVL, N2, N34, N4, NBL, + & NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND + LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK, + & RSVEC, UCTOL, UPPER +* +* Local Arrays +* + REAL FASTR(5) +* +* Intrinsic Functions +* + INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT +* +* External Functions +* .. from BLAS + REAL SDOT, SNRM2 + EXTERNAL SDOT, SNRM2 + INTEGER ISAMAX + EXTERNAL ISAMAX +* .. from LAPACK + REAL SLAMCH + EXTERNAL SLAMCH + LOGICAL LSAME + EXTERNAL LSAME +* +* External Subroutines +* .. from BLAS + EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP +* .. from LAPACK + EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA +* + EXTERNAL SGSVJ0, SGSVJ1 +* +* Test the input arguments +* + LSVEC = LSAME( JOBU, 'U' ) + UCTOL = LSAME( JOBU, 'C' ) + RSVEC = LSAME( JOBV, 'V' ) + APPLV = LSAME( JOBV, 'A' ) + UPPER = LSAME( JOBA, 'U' ) + LOWER = LSAME( JOBA, 'L' ) +* + IF ( .NOT.( UPPER .OR. LOWER .OR. LSAME(JOBA,'G') ) ) THEN + INFO = - 1 + ELSE IF ( .NOT.( LSVEC .OR. UCTOL .OR. LSAME(JOBU,'N') ) ) THEN + INFO = - 2 + ELSE IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N') ) ) THEN + INFO = - 3 + ELSE IF ( M .LT. 0 ) THEN + INFO = - 4 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN + INFO = - 5 + ELSE IF ( LDA .LT. M ) THEN + INFO = - 7 + ELSE IF ( MV .LT. 0 ) THEN + INFO = - 9 + ELSE IF ( ( RSVEC .AND. (LDV .LT. N ) ) .OR. + & ( APPLV .AND. (LDV .LT. MV) ) ) THEN + INFO = -11 + ELSE IF ( UCTOL .AND. (WORK(1) .LE. ONE) ) THEN + INFO = - 12 + ELSE IF ( LWORK .LT. MAX0( M + N , 6 ) ) THEN + INFO = - 13 + ELSE + INFO = 0 + END IF +* +* #:( + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SGESVJ', -INFO ) + RETURN + END IF +* +* #:) Quick return for void matrix +* + IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN +* +* Set numerical parameters +* The stopping criterion for Jacobi rotations is +* +* max_{i<>j}|A(:,i)^T * A(:,j)|/(||A(:,i)||*||A(:,j)||) < CTOL*EPS +* +* where EPS is the round-off and CTOL is defined as follows: +* + IF ( UCTOL ) THEN +* ... user controlled + CTOL = WORK(1) + ELSE +* ... default + IF ( LSVEC .OR. RSVEC .OR. APPLV ) THEN + CTOL = SQRT(FLOAT(M)) + ELSE + CTOL = FLOAT(M) + END IF + END IF +* ... and the machine dependent parameters are +*[!] (Make sure that SLAMCH() works properly on the target machine.) +* + EPSILON = SLAMCH('Epsilon') + ROOTEPS = SQRT(EPSILON) + SFMIN = SLAMCH('SafeMinimum') + ROOTSFMIN = SQRT(SFMIN) + SMALL = SFMIN / EPSILON + BIG = SLAMCH('Overflow') + ROOTBIG = ONE / ROOTSFMIN + LARGE = BIG / SQRT(FLOAT(M*N)) + BIGTHETA = ONE / ROOTEPS +* + TOL = CTOL * EPSILON + ROOTTOL = SQRT(TOL) +* + IF ( FLOAT(M)*EPSILON .GE. ONE ) THEN + INFO = - 5 + CALL XERBLA( 'SGESVJ', -INFO ) + RETURN + END IF +* +* Initialize the right singular vector matrix. +* + IF ( RSVEC ) THEN + MVL = N + CALL SLASET( 'A', MVL, N, ZERO, ONE, V, LDV ) + ELSE IF ( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV +* +* Initialize SVA( 1:N ) = ( ||A e_i||_2, i = 1:N ) +*(!) If necessary, scale A to protect the largest singular value +* from overflow. It is possible that saving the largest singular +* value destroys the information about the small ones. +* This initial scaling is almost minimal in the sense that the +* goal is to make sure that no column norm overflows, and that +* SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries +* in A are detected, the procedure returns with INFO=-6. +* + SCALE = ONE / SQRT(FLOAT(M)*FLOAT(N)) + NOSCALE = .TRUE. + GOSCALE = .TRUE. +* + IF ( LOWER ) THEN +* the input matrix is M-by-N lower triangular (trapezoidal) + DO 1874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL SLASSQ( M-p+1, A(p,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 6 + CALL XERBLA( 'SGESVJ', -INFO ) + RETURN + END IF + AAQQ = SQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCALE = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALE ) + IF ( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 1873 q = 1, p - 1 + SVA(q) = SVA(q)*SCALE + 1873 CONTINUE + END IF + END IF + 1874 CONTINUE + ELSE IF ( UPPER ) THEN +* the input matrix is M-by-N upper triangular (trapezoidal) + DO 2874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL SLASSQ( p, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 6 + CALL XERBLA( 'SGESVJ', -INFO ) + RETURN + END IF + AAQQ = SQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCALE = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALE ) + IF ( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 2873 q = 1, p - 1 + SVA(q) = SVA(q)*SCALE + 2873 CONTINUE + END IF + END IF + 2874 CONTINUE + ELSE +* the input matrix is M-by-N general dense + DO 3874 p = 1, N + AAPP = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ ) + IF ( AAPP .GT. BIG ) THEN + INFO = - 6 + CALL XERBLA( 'SGESVJ', -INFO ) + RETURN + END IF + AAQQ = SQRT(AAQQ) + IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN + SVA(p) = AAPP * AAQQ + ELSE + NOSCALE = .FALSE. + SVA(p) = AAPP * ( AAQQ * SCALE ) + IF ( GOSCALE ) THEN + GOSCALE = .FALSE. + DO 3873 q = 1, p - 1 + SVA(q) = SVA(q)*SCALE + 3873 CONTINUE + END IF + END IF + 3874 CONTINUE + END IF +* + IF ( NOSCALE ) SCALE = ONE +* +* Move the smaller part of the spectrum from the underflow threshold +*(!) Start by determining the position of the nonzero entries of the +* array SVA() relative to ( SFMIN, BIG ). +* + AAPP = ZERO + AAQQ = BIG + DO 4781 p = 1, N + IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) ) + AAPP = AMAX1( AAPP, SVA(p) ) + 4781 CONTINUE +* +* #:) Quick return for zero matrix +* + IF ( AAPP .EQ. ZERO ) THEN + IF ( LSVEC ) CALL SLASET( 'G', M, N, ZERO, ONE, A, LDA ) + WORK(1) = ONE + WORK(2) = ZERO + WORK(3) = ZERO + WORK(4) = ZERO + WORK(5) = ZERO + WORK(6) = ZERO + RETURN + END IF +* +* #:) Quick return for one-column matrix +* + IF ( N .EQ. 1 ) THEN + IF ( LSVEC ) + & CALL SLASCL( 'G',0,0,SVA(1),SCALE,M,1,A(1,1),LDA,IERR ) + WORK(1) = ONE / SCALE + IF ( SVA(1) .GE. SFMIN ) THEN + WORK(2) = ONE + ELSE + WORK(2) = ZERO + END IF + WORK(3) = ZERO + WORK(4) = ZERO + WORK(5) = ZERO + WORK(6) = ZERO + RETURN + END IF +* +* Protect small singular values from underflow, and try to +* avoid underflows/overflows in computing Jacobi rotations. +* + SN = SQRT( SFMIN / EPSILON ) + TEMP1 = SQRT( BIG / FLOAT(N) ) + IF ( (AAPP.LE.SN).OR.(AAQQ.GE.TEMP1) + & .OR.((SN.LE.AAQQ).AND.(AAPP.LE.TEMP1)) ) THEN + TEMP1 = AMIN1(BIG,TEMP1/AAPP) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.LE.TEMP1) ) THEN + TEMP1 = AMIN1( SN / AAQQ, BIG/(AAPP*SQRT(FLOAT(N))) ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF ( (AAQQ.GE.SN).AND.(AAPP.GE.TEMP1) ) THEN + TEMP1 = AMAX1( SN / AAQQ, TEMP1 / AAPP ) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.GE.TEMP1) ) THEN + TEMP1 = AMIN1( SN / AAQQ, BIG / (SQRT(FLOAT(N))*AAPP)) +* AAQQ = AAQQ*TEMP1 +* AAPP = AAPP*TEMP1 + ELSE + TEMP1 = ONE + END IF +* +* Scale, if necessary +* + IF ( TEMP1 .NE. ONE ) THEN + CALL SLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR ) + END IF + SCALE = TEMP1 * SCALE + IF ( SCALE .NE. ONE ) THEN + CALL SLASCL( JOBA, 0, 0, ONE, SCALE, M, N, A, LDA, IERR ) + SCALE = ONE / SCALE + END IF +* +* Row-cyclic Jacobi SVD algorithm with column pivoting +* + EMPTSW = ( N * ( N - 1 ) ) / 2 + NOTROT = 0 + FASTR(1) = ZERO +* +* A is represented in factored form A = A * diag(WORK), where diag(WORK) +* is initialized to identity. WORK is updated during fast scaled +* rotations. +* + DO 1868 q = 1, N + WORK(q) = ONE + 1868 CONTINUE +* +* + SWBAND = 3 +*[TP] SWBAND is a tuning parameter [TP]. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure +* works on pivots inside a band-like region around the diagonal. +* The boundaries are determined dynamically, based on the number of +* pivots above a threshold. +* + KBL = MIN0( 8, N ) +*[TP] KBL is a tuning parameter that defines the tile size in the +* tiling of the p-q loops of pivot pairs. In general, an optimal +* value of KBL depends on the matrix dimensions and on the +* parameters of the computer's memory. +* + NBL = N / KBL + IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1 +* + BLSKIP = KBL**2 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. +* + ROWSKIP = MIN0( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. +* + LKAHEAD = 1 +*[TP] LKAHEAD is a tuning parameter. +* +* Quasi block transformations, using the lower (upper) triangular +* structure of the input matrix. The quasi-block-cycling usually +* invokes cubic convergence. Big part of this cycle is done inside +* canonical subspaces of dimensions less than M. +* + IF ( (LOWER .OR. UPPER) .AND. (N .GT. MAX0(64, 4*KBL)) ) THEN +*[TP] The number of partition levels and the actual partition are +* tuning parameters. + N4 = N / 4 + N2 = N / 2 + N34 = 3 * N4 + IF ( APPLV ) THEN + q = 0 + ELSE + q = 1 + END IF +* + IF ( LOWER ) THEN +* +* This works very well on lower triangular matrices, in particular +* in the framework of the preconditioned Jacobi SVD (xGEJSV). +* The idea is simple: +* [+ 0 0 0] Note that Jacobi transformations of [0 0] +* [+ + 0 0] [0 0] +* [+ + x 0] actually work on [x 0] [x 0] +* [+ + x x] [x x]. [x x] +* + CALL SGSVJ0(JOBV,M-N34,N-N34,A(N34+1,N34+1),LDA,WORK(N34+1), + & SVA(N34+1),MVL,V(N34*q+1,N34+1),LDV,EPSILON,SFMIN,TOL,2, + & WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ0( JOBV,M-N2,N34-N2,A(N2+1,N2+1),LDA,WORK(N2+1), + & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,2, + & WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ1( JOBV,M-N2,N-N2,N4,A(N2+1,N2+1),LDA,WORK(N2+1), + & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1, + & WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ0( JOBV,M-N4,N2-N4,A(N4+1,N4+1),LDA,WORK(N4+1), + & SVA(N4+1),MVL,V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1, + & WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ0( JOBV,M,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ1( JOBV,M,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR ) +* +* + ELSE IF ( UPPER ) THEN +* +* + CALL SGSVJ0( JOBV,N4,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,2,WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ0(JOBV,N2,N4,A(1,N4+1),LDA,WORK(N4+1),SVA(N4+1),MVL, + & V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,WORK(N+1),LWORK-N, + & IERR ) +* + CALL SGSVJ1( JOBV,N2,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON, + & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR ) +* + CALL SGSVJ0( JOBV,N2+N4,N4,A(1,N2+1),LDA,WORK(N2+1),SVA(N2+1),MVL, + & V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1, + & WORK(N+1),LWORK-N,IERR ) + + END IF +* + END IF +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* +* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs +* 1 <= p < q <= N. This is the first step toward a blocked implementation +* of the rotations. New implementation, based on block transformations, +* is under development. +* + DO 2000 ibr = 1, NBL +* + igl = ( ibr - 1 ) * KBL + 1 +* + DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr ) +* + igl = igl + ir1 * KBL +* + DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1) +* +* .. de Rijk's pivoting +* + q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + CALL SSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = WORK(p) + WORK(p) = WORK(q) + WORK(q) = TEMP1 + END IF +* + IF ( ir1 .EQ. 0 ) THEN +* +* Column norms are periodically updated by explicit +* norm computation. +* Caveat: +* Unfortunately, some BLAS implementations compute SNRM2(M,A(1,p),1) +* as SQRT(SDOT(M,A(1,p),1,A(1,p),1)), which may cause the result to +* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and to +* underflow for ||A(:,p)||_2 < SQRT(underflow_threshold). +* Hence, SNRM2 cannot be trusted, not even in the case when +* the true norm is far from the under(over)flow boundaries. +* If properly implemented SNRM2 is available, the IF-THEN-ELSE +* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p)". +* + IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN + SVA(p) = SNRM2( M, A(1,p), 1 ) * WORK(p) + ELSE + TEMP1 = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, TEMP1, AAPP ) + SVA(p) = TEMP1 * SQRT(AAPP) * WORK(p) + END IF + AAPP = SVA(p) + ELSE + AAPP = SVA(p) + END IF +* + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2002 q = p + 1, MIN0( igl + KBL - 1, N ) +* + AAQQ = SVA(q) +* + IF ( AAQQ .GT. ZERO ) THEN +* + AAPP0 = AAPP + IF ( AAQQ .GE. ONE ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL SLASCL( 'G', 0, 0, AAPP, WORK(p), M, + & 1, WORK(N+1), LDA, IERR ) + AAPQ = SDOT( M, WORK(N+1),1, A(1,q),1 )*WORK(q) / AAQQ + END IF + ELSE + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,q), 1, WORK(N+1), 1 ) + CALL SLASCL( 'G', 0, 0, AAQQ, WORK(q), M, + & 1, WORK(N+1), LDA, IERR ) + AAPQ = SDOT( M, WORK(N+1),1, A(1,p),1 )*WORK(p) / AAPP + END IF + END IF +* + MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( ABS( AAPQ ) .GT. TOL ) THEN +* +* .. rotate +*[RTD] ROTATED = ROTATED + ONE +* + IF ( ir1 .EQ. 0 ) THEN + NOTROT = 0 + PSKIPPED = 0 + ISWROT = ISWROT + 1 + END IF +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ +* + IF ( ABS( THETA ) .GT. BIGTHETA ) THEN +* + T = HALF / THETA + FASTR(3) = T * WORK(p) / WORK(q) + FASTR(4) = - T * WORK(q) / WORK(p) + CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ ) + MXSINJ = AMAX1( MXSINJ, ABS(T) ) +* + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - SIGN(ONE,AAPQ) + T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) ) + CS = SQRT( ONE / ( ONE + T*T ) ) + SN = T * CS +* + MXSINJ = AMAX1( MXSINJ, ABS(SN) ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( AMAX1(ZERO, ONE-T*AQOAP*AAPQ) ) +* + APOAQ = WORK(p) / WORK(q) + AQOAP = WORK(q) / WORK(p) + IF ( WORK(p) .GE. ONE ) THEN + IF ( WORK(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) * CS + CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1) + END IF + END IF + ELSE + IF ( WORK(q) .GE. ONE ) THEN + CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + ELSE + IF ( WORK(p) .GE. WORK(q) ) THEN + CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL SAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL SAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE +* .. have to use modified Gram-Schmidt like transformation + CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL SLASCL( 'G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR ) + CALL SLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR ) + TEMP1 = -AAPQ * WORK(p) / WORK(q) + CALL SAXPY ( M, TEMP1, WORK(N+1), 1, A(1,q), 1 ) + CALL SLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR ) + SVA(q) = AAQQ*SQRT( AMAX1( ZERO, ONE - AAPQ*AAPQ ) ) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q), SVA(p) +* recompute SVA(q), SVA(p). +* + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = SNRM2( M, A(1,q), 1 ) * WORK(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * SQRT(AAQQ) * WORK(q) + END IF + END IF + IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * SQRT(AAPP) * WORK(p) + END IF + SVA(p) = AAPP + END IF +* + ELSE +* A(:,p) and A(:,q) already numerically orthogonal + IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1 +*[RTD] SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + END IF + ELSE +* A(:,q) is zero column + IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + IF ( ir1 .EQ. 0 ) AAPP = - AAPP + NOTROT = 0 + GO TO 2103 + END IF +* + 2002 CONTINUE +* END q-LOOP +* + 2103 CONTINUE +* bailed out of q-loop +* + SVA(p) = AAPP +* + ELSE + SVA(p) = AAPP + IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) ) + & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p + END IF +* + 2001 CONTINUE +* end of the p-loop +* end of doing the block ( ibr, ibr ) + 1002 CONTINUE +* end of ir1-loop +* +* ... go to the off diagonal blocks +* + igl = ( ibr - 1 ) * KBL + 1 +* + DO 2010 jbc = ibr + 1, NBL +* + jgl = ( jbc - 1 ) * KBL + 1 +* +* doing the block at ( ibr, jbc ) +* + IJBLSK = 0 + DO 2100 p = igl, MIN0( igl + KBL - 1, N ) +* + AAPP = SVA(p) + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2200 q = jgl, MIN0( jgl + KBL - 1, N ) +* + AAQQ = SVA(q) + IF ( AAQQ .GT. ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* Safe Gram matrix computation +* + IF ( AAQQ .GE. ONE ) THEN + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ) .LE. AAPP + END IF + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL SLASCL( 'G', 0, 0, AAPP, WORK(p), M, + & 1, WORK(N+1), LDA, IERR ) + AAPQ = SDOT( M, WORK(N+1), 1, A(1,q), 1 ) * + & WORK(q) / AAQQ + END IF + ELSE + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ .LE. ( AAPP / SMALL ) + END IF + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) * + & WORK(p) * WORK(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,q), 1, WORK(N+1), 1 ) + CALL SLASCL( 'G', 0, 0, AAQQ, WORK(q), M, 1, + & WORK(N+1), LDA, IERR ) + AAPQ = SDOT(M,WORK(N+1),1,A(1,p),1) * WORK(p) / AAPP + END IF + END IF +* + MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( ABS( AAPQ ) .GT. TOL ) THEN + NOTROT = 0 +*[RTD] ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ + IF ( AAQQ .GT. AAPP0 ) THETA = - THETA +* + IF ( ABS( THETA ) .GT. BIGTHETA ) THEN + T = HALF / THETA + FASTR(3) = T * WORK(p) / WORK(q) + FASTR(4) = -T * WORK(q) / WORK(p) + CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) ) + MXSINJ = AMAX1( MXSINJ, ABS(T) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - SIGN(ONE,AAPQ) + IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN + T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) ) + CS = SQRT( ONE / ( ONE + T*T ) ) + SN = T * CS + MXSINJ = AMAX1( MXSINJ, ABS(SN) ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ) +* + APOAQ = WORK(p) / WORK(q) + AQOAP = WORK(q) / WORK(p) + IF ( WORK(p) .GE. ONE ) THEN +* + IF ( WORK(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) * CS + CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + IF ( RSVEC ) THEN + CALL SAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 ) + CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 ) + END IF + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + END IF + ELSE + IF ( WORK(q) .GE. ONE ) THEN + CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + IF ( RSVEC ) THEN + CALL SAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 ) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 ) + END IF + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + ELSE + IF ( WORK(p) .GE. WORK(q) ) THEN + CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + WORK(p) = WORK(p) * CS + WORK(q) = WORK(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL SAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + WORK(p) = WORK(p) / CS + WORK(q) = WORK(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE + IF ( AAPP .GT. AAQQ ) THEN + CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 ) + CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR) + CALL SLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR) + TEMP1 = -AAPQ * WORK(p) / WORK(q) + CALL SAXPY(M,TEMP1,WORK(N+1),1,A(1,q),1) + CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR) + SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + ELSE + CALL SCOPY( M, A(1,q), 1, WORK(N+1), 1 ) + CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK(N+1),LDA,IERR) + CALL SLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR) + TEMP1 = -AAPQ * WORK(q) / WORK(p) + CALL SAXPY(M,TEMP1,WORK(N+1),1,A(1,p),1) + CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR) + SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = SNRM2( M, A(1,q), 1 ) * WORK(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * SQRT(AAQQ) * WORK(q) + END IF + END IF + IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * SQRT(AAPP) * WORK(p) + END IF + SVA(p) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 +*[RTD] SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN + SVA(p) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE +* + SVA(p) = AAPP +* + ELSE +* + IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1 + IF ( AAPP .LT. ZERO ) NOTROT = 0 +* + END IF +* + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN0( igl + KBL - 1, N ) + SVA(p) = ABS(SVA(p)) + 2012 CONTINUE +*** + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN + SVA(N) = SNRM2( M, A(1,N), 1 ) * WORK(N) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,N), 1, T, AAPP ) + SVA(N) = T * SQRT(AAPP) * WORK(N) + END IF +* +* Additional steering devices +* + IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + & ( ISWROT .LE. N ) ) ) + & SWBAND = i +* + IF ( (i .GT. SWBAND+1) .AND. (MXAAPQ .LT. SQRT(FLOAT(N))*TOL) + & .AND. (FLOAT(N)*MXAAPQ*MXSINJ .LT. TOL) ) THEN + GO TO 1994 + END IF +* + IF ( NOTROT .GE. EMPTSW ) GO TO 1994 +* + 1993 CONTINUE +* end i=1:NSWEEP loop +* +* #:( Reaching this point means that the procedure has not converged. + INFO = NSWEEP - 1 + GO TO 1995 +* + 1994 CONTINUE +* #:) Reaching this point means numerical convergence after the i-th +* sweep. +* + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the singular values and find how many are above +* the underflow threshold. +* + N2 = 0 + N4 = 0 + DO 5991 p = 1, N - 1 + q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = WORK(p) + WORK(p) = WORK(q) + WORK(q) = TEMP1 + CALL SSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + END IF + IF ( SVA(p) .NE. ZERO ) THEN + N4 = N4 + 1 + IF ( SVA(p)*SCALE .GT. SFMIN ) N2 = N2 + 1 + END IF + 5991 CONTINUE + IF ( SVA(N) .NE. ZERO ) THEN + N4 = N4 + 1 + IF ( SVA(N)*SCALE .GT. SFMIN ) N2 = N2 + 1 + END IF +* +* Normalize the left singular vectors. +* + IF ( LSVEC .OR. UCTOL ) THEN + DO 1998 p = 1, N2 + CALL SSCAL( M, WORK(p) / SVA(p), A(1,p), 1 ) + 1998 CONTINUE + END IF +* +* Scale the product of Jacobi rotations (assemble the fast rotations). +* + IF ( RSVEC ) THEN + IF ( APPLV ) THEN + DO 2398 p = 1, N + CALL SSCAL( MVL, WORK(p), V(1,p), 1 ) + 2398 CONTINUE + ELSE + DO 2399 p = 1, N + TEMP1 = ONE / SNRM2(MVL, V(1,p), 1 ) + CALL SSCAL( MVL, TEMP1, V(1,p), 1 ) + 2399 CONTINUE + END IF + END IF +* +* Undo scaling, if necessary (and possible). + IF ( ((SCALE.GT.ONE).AND.(SVA(1).LT.(BIG/SCALE))) + & .OR.((SCALE.LT.ONE).AND.(SVA(N2).GT.(SFMIN/SCALE))) ) THEN + DO 2400 p = 1, N + SVA(p) = SCALE*SVA(p) + 2400 CONTINUE + SCALE = ONE + END IF +* + WORK(1) = SCALE +* The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE +* then some of the singular values may overflow or underflow and +* the spectrum is given in this factored representation. +* + WORK(2) = FLOAT(N4) +* N4 is the number of computed nonzero singular values of A. +* + WORK(3) = FLOAT(N2) +* N2 is the number of singular values of A greater than SFMIN. +* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers +* that may carry some information. +* + WORK(4) = FLOAT(i) +* i is the index of the last sweep before declaring convergence. +* + WORK(5) = MXAAPQ +* MXAAPQ is the largest absolute value of scaled pivots in the +* last sweep +* + WORK(6) = MXSINJ +* MXSINJ is the largest absolute value of the sines of Jacobi angles +* in the last sweep +* + RETURN +* .. +* .. END OF SGESVJ +* .. + END +* diff --git a/SRC/sgesvx.f b/SRC/sgesvx.f index 24dc987b..25094bdb 100644 --- a/SRC/sgesvx.f +++ b/SRC/sgesvx.f @@ -2,7 +2,7 @@ $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgesvxx.f b/SRC/sgesvxx.f new file mode 100644 index 00000000..1021c24a --- /dev/null +++ b/SRC/sgesvxx.f @@ -0,0 +1,633 @@ + SUBROUTINE SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + REAL R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SGESVXX uses the LU factorization to compute the solution to a +* real system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. SGESVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* SGESVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* SGESVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what SGESVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose = Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is +* not 'N', then A must have been equilibrated by the scaling +* factors in R and/or C. A is not modified if FACT = 'F' or +* 'N', or if FACT = 'E' and EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) REAL array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the factors L and U from the factorization +* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then +* AF is the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by SGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) REAL array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) REAL array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) REAL array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In SGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, COLCND, RCMAX, RCMIN, ROWCND, + $ SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, SLA_RPVGRW + LOGICAL LSAME + REAL SLAMCH, SLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL SGEEQUB, SGETRF, SGETRS, SLACPY, SLAQGE, + $ XERBLA, SLASCL2, SGERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in SGERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until SGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL SGEEQUB( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL SLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL SLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL SLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL SLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL SGETRF( N, N, AF, LDAF, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = SLA_RPVGRW( N, INFO, A, LDA, AF, LDAF ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = SLA_RPVGRW( N, N, A, LDA, AF, LDAF ) +* +* Compute the solution matrix X. +* + CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL SGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL SGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL SLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL SLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of SGESVXX + + END diff --git a/SRC/sgetc2.f b/SRC/sgetc2.f index db52cff6..a090ea0b 100644 --- a/SRC/sgetc2.f +++ b/SRC/sgetc2.f @@ -1,6 +1,6 @@ SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgetf2.f b/SRC/sgetf2.f index d5a045d5..02d196d8 100644 --- a/SRC/sgetf2.f +++ b/SRC/sgetf2.f @@ -1,6 +1,6 @@ SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgetrf.f b/SRC/sgetrf.f index 7f3c90a6..34e16bb8 100644 --- a/SRC/sgetrf.f +++ b/SRC/sgetrf.f @@ -1,6 +1,6 @@ SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgetri.f b/SRC/sgetri.f index 3eb1f346..bd73dae7 100644 --- a/SRC/sgetri.f +++ b/SRC/sgetri.f @@ -1,6 +1,6 @@ SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgetrs.f b/SRC/sgetrs.f index 3c82cf87..839d70d8 100644 --- a/SRC/sgetrs.f +++ b/SRC/sgetrs.f @@ -1,6 +1,6 @@ SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggbak.f b/SRC/sggbak.f index fddd264e..58cf2168 100644 --- a/SRC/sggbak.f +++ b/SRC/sggbak.f @@ -1,7 +1,7 @@ SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggbal.f b/SRC/sggbal.f index 9c82f373..41602982 100644 --- a/SRC/sggbal.f +++ b/SRC/sggbal.f @@ -1,7 +1,7 @@ SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgges.f b/SRC/sgges.f index 00f16a5e..61c764c5 100644 --- a/SRC/sgges.f +++ b/SRC/sgges.f @@ -2,7 +2,7 @@ $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, $ LDVSR, WORK, LWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggesx.f b/SRC/sggesx.f index 241bc660..55c12b68 100644 --- a/SRC/sggesx.f +++ b/SRC/sggesx.f @@ -3,7 +3,7 @@ $ VSR, LDVSR, RCONDE, RCONDV, WORK, LWORK, IWORK, $ LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggev.f b/SRC/sggev.f index 59dbe214..63d1ad11 100644 --- a/SRC/sggev.f +++ b/SRC/sggev.f @@ -1,7 +1,7 @@ SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI, $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggevx.f b/SRC/sggevx.f index 622ac998..5b641cc8 100644 --- a/SRC/sggevx.f +++ b/SRC/sggevx.f @@ -3,7 +3,7 @@ $ IHI, LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, $ RCONDV, WORK, LWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggglm.f b/SRC/sggglm.f index 5ffb2a43..aebabd0d 100644 --- a/SRC/sggglm.f +++ b/SRC/sggglm.f @@ -1,7 +1,7 @@ SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgghrd.f b/SRC/sgghrd.f index db7c1e6d..86b72c24 100644 --- a/SRC/sgghrd.f +++ b/SRC/sgghrd.f @@ -1,7 +1,7 @@ SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgglse.f b/SRC/sgglse.f index c821782e..950fc836 100644 --- a/SRC/sgglse.f +++ b/SRC/sgglse.f @@ -1,7 +1,7 @@ SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggqrf.f b/SRC/sggqrf.f index 7d2c523d..806028b5 100644 --- a/SRC/sggqrf.f +++ b/SRC/sggqrf.f @@ -1,7 +1,7 @@ SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggrqf.f b/SRC/sggrqf.f index e1217663..fac2680b 100644 --- a/SRC/sggrqf.f +++ b/SRC/sggrqf.f @@ -1,7 +1,7 @@ SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggsvd.f b/SRC/sggsvd.f index e3f042c3..2d60c695 100644 --- a/SRC/sggsvd.f +++ b/SRC/sggsvd.f @@ -2,7 +2,7 @@ $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sggsvp.f b/SRC/sggsvp.f index e1263d60..48b929b1 100644 --- a/SRC/sggsvp.f +++ b/SRC/sggsvp.f @@ -2,7 +2,7 @@ $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -109,7 +109,7 @@ * The leading dimension of the array U. LDU >= max(1,M) if * JOBU = 'U'; LDU >= 1 otherwise. * -* V (output) REAL array, dimension (LDV,M) +* V (output) REAL array, dimension (LDV,P) * If JOBV = 'V', V contains the orthogonal matrix V. * If JOBV = 'N', V is not referenced. * diff --git a/SRC/sgsvj0.f b/SRC/sgsvj0.f new file mode 100644 index 00000000..975205e3 --- /dev/null +++ b/SRC/sgsvj0.f @@ -0,0 +1,835 @@ + SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, + & SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* Scalar Arguments +* + IMPLICIT NONE + INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP + REAL EPS, SFMIN, TOL + CHARACTER*1 JOBV +* +* Array Arguments +* + REAL A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), + & WORK( LWORK ) +* .. +* +* Purpose +* ~~~~~~~ +* SGSVJ0 is called from SGESVJ as a pre-processor and that is its main +* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but +* it does not check convergence (stopping criterion). Few tuning +* parameters (marked by [TP]) are available for the implementer. +* +* Further details +* ~~~~~~~~~~~~~~~ +* SGSVJ0 is used just to enable SGESVJ to call a simplified version of +* itself to work on a submatrix of the original matrix. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* Bugs, Examples and Comments +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Please report all bugs and send interesting test examples and comments to +* drmac@math.hr. Thank you. +* +* Arguments +* ~~~~~~~~~ +* +* JOBV (input) CHARACTER*1 +* Specifies whether the output from this procedure is used +* to compute the matrix V: +* = 'V': the product of the Jacobi rotations is accumulated +* by postmulyiplying the N-by-N array V. +* (See the description of V.) +* = 'A': the product of the Jacobi rotations is accumulated +* by postmulyiplying the MV-by-N array V. +* (See the descriptions of MV and V.) +* = 'N': the Jacobi rotations are not accumulated. +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. +* M >= N >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, M-by-N matrix A, such that A*diag(D) represents +* the input matrix. +* On exit, +* A_onexit * D_onexit represents the input matrix A*diag(D) +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of D, TOL and NSWEEP.) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* D (input/workspace/output) REAL array, dimension (N) +* The array D accumulates the scaling factors from the fast scaled +* Jacobi rotations. +* On entry, A*diag(D) represents the input matrix. +* On exit, A_onexit*diag(D_onexit) represents the input matrix +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of A, TOL and NSWEEP.) +* +* SVA (input/workspace/output) REAL array, dimension (N) +* On entry, SVA contains the Euclidean norms of the columns of +* the matrix A*diag(D). +* On exit, SVA contains the Euclidean norms of the columns of +* the matrix onexit*diag(D_onexit). +* +* MV (input) INTEGER +* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then MV is not referenced. +* +* V (input/output) REAL array, dimension (LDV,N) +* If JOBV .EQ. 'V' then N rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV >= 1. +* If JOBV = 'V', LDV .GE. N. +* If JOBV = 'A', LDV .GE. MV. +* +* EPS (input) INTEGER +* EPS = SLAMCH('Epsilon') +* +* SFMIN (input) INTEGER +* SFMIN = SLAMCH('Safe Minimum') +* +* TOL (input) REAL +* TOL is the threshold for Jacobi rotations. For a pair +* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +* applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. +* +* NSWEEP (input) INTEGER +* NSWEEP is the number of sweeps of Jacobi rotations to be +* performed. +* +* WORK (workspace) REAL array, dimension LWORK. +* +* LWORK (input) INTEGER +* LWORK is the dimension of WORK. LWORK .GE. M. +* +* INFO (output) INTEGER +* = 0 : successful exit. +* < 0 : if INFO = -i, then the i-th argument had an illegal value +* +* Local Parameters + REAL ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 ) + +* Local Scalars + REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, BIGTHETA, + & CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, + & ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN + INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, ISWROT, + & jbc, jgl, KBL, LKAHEAD, MVL, NBL, NOTROT, p, PSKIPPED, + & q, ROWSKIP, SWBAND + LOGICAL APPLV, ROTOK, RSVEC + +* Local Arrays + REAL FASTR(5) +* +* Intrinsic Functions + INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT +* +* External Functions + REAL SDOT, SNRM2 + INTEGER ISAMAX + LOGICAL LSAME + EXTERNAL ISAMAX, LSAME, SDOT, SNRM2 +* +* External Subroutines + EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP +* +* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +* + APPLV = LSAME(JOBV,'A') + RSVEC = LSAME(JOBV,'V') + IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN + INFO = -1 + ELSE IF ( M .LT. 0 ) THEN + INFO = -2 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN + INFO = -3 + ELSE IF ( LDA .LT. M ) THEN + INFO = -5 + ELSE IF ( MV .LT. 0 ) THEN + INFO = -8 + ELSE IF ( LDV .LT. M ) THEN + INFO = -10 + ELSE IF ( TOL .LE. EPS ) THEN + INFO = -13 + ELSE IF ( NSWEEP .LT. 0 ) THEN + INFO = -14 + ELSE IF ( LWORK .LT. M ) THEN + INFO = -16 + ELSE + INFO = 0 + END IF +* +* #:( + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SGSVJ0', -INFO ) + RETURN + END IF +* + IF ( RSVEC ) THEN + MVL = N + ELSE IF ( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV + + ROOTEPS = SQRT(EPS) + ROOTSFMIN = SQRT(SFMIN) + SMALL = SFMIN / EPS + BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + BIGTHETA = ONE / ROOTEPS + ROOTTOL = SQRT(TOL) +* +* +* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- +* + EMPTSW = ( N * ( N - 1 ) ) / 2 + NOTROT = 0 + FASTR(1) = ZERO +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + + SWBAND = 0 +*[TP] SWBAND is a tuning parameter. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure +* ...... + + KBL = MIN0( 8, N ) +*[TP] KBL is a tuning parameter that defines the tile size in the +* tiling of the p-q loops of pivot pairs. In general, an optimal +* value of KBL depends on the matrix dimensions and on the +* parameters of the computer's memory. +* + NBL = N / KBL + IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1 + + BLSKIP = ( KBL**2 ) + 1 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. + + ROWSKIP = MIN0( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. + + LKAHEAD = 1 +*[TP] LKAHEAD is a tuning parameter. + SWBAND = 0 + PSKIPPED = 0 +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* + DO 2000 ibr = 1, NBL + + igl = ( ibr - 1 ) * KBL + 1 +* + DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr ) +* + igl = igl + ir1 * KBL +* + DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1) + +* .. de Rijk's pivoting + q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + CALL SSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = D(p) + D(p) = D(q) + D(q) = TEMP1 + END IF +* + IF ( ir1 .EQ. 0 ) THEN +* +* Column norms are periodically updated by explicit +* norm computation. +* Caveat: +* Some BLAS implementations compute SNRM2(M,A(1,p),1) +* as SQRT(SDOT(M,A(1,p),1,A(1,p),1)), which may result in +* overflow for ||A(:,p)||_2 > SQRT(overflow_threshold), and +* undeflow for ||A(:,p)||_2 < SQRT(underflow_threshold). +* Hence, SNRM2 cannot be trusted, not even in the case when +* the true norm is far from the under(over)flow boundaries. +* If properly implemented SNRM2 is available, the IF-THEN-ELSE +* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * D(p)". +* + IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN + SVA(p) = SNRM2( M, A(1,p), 1 ) * D(p) + ELSE + TEMP1 = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, TEMP1, AAPP ) + SVA(p) = TEMP1 * SQRT(AAPP) * D(p) + END IF + AAPP = SVA(p) + ELSE + AAPP = SVA(p) + END IF + +* + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2002 q = p + 1, MIN0( igl + KBL - 1, N ) +* + AAQQ = SVA(q) + + IF ( AAQQ .GT. ZERO ) THEN +* + AAPP0 = AAPP + IF ( AAQQ .GE. ONE ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,p), 1, WORK, 1 ) + CALL SLASCL( 'G', 0, 0, AAPP, D(p), M, + & 1, WORK, LDA, IERR ) + AAPQ = SDOT( M, WORK,1, A(1,q),1 )*D(q) / AAQQ + END IF + ELSE + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,q), 1, WORK, 1 ) + CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, + & 1, WORK, LDA, IERR ) + AAPQ = SDOT( M, WORK,1, A(1,p),1 )*D(p) / AAPP + END IF + END IF +* + MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( ABS( AAPQ ) .GT. TOL ) THEN +* +* .. rotate +* ROTATED = ROTATED + ONE +* + IF ( ir1 .EQ. 0 ) THEN + NOTROT = 0 + PSKIPPED = 0 + ISWROT = ISWROT + 1 + END IF +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ +* + IF ( ABS( THETA ) .GT. BIGTHETA ) THEN +* + T = HALF / THETA + FASTR(3) = T * D(p) / D(q) + FASTR(4) = - T * D(q) / D(p) + CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ ) + MXSINJ = AMAX1( MXSINJ, ABS(T) ) +* + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - SIGN(ONE,AAPQ) + T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) ) + CS = SQRT( ONE / ( ONE + T*T ) ) + SN = T * CS +* + MXSINJ = AMAX1( MXSINJ, ABS(SN) ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( AMAX1(ZERO, ONE-T*AQOAP*AAPQ) ) +* + APOAQ = D(p) / D(q) + AQOAP = D(q) / D(p) + IF ( D(p) .GE. ONE ) THEN + IF ( D(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + D(p) = D(p) * CS + D(q) = D(q) * CS + CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1) + END IF + END IF + ELSE + IF ( D(q) .GE. ONE ) THEN + CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + ELSE + IF ( D(p) .GE. D(q) ) THEN + CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL SAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL SAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE +* .. have to use modified Gram-Schmidt like transformation + CALL SCOPY( M, A(1,p), 1, WORK, 1 ) + CALL SLASCL( 'G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR ) + CALL SLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR ) + TEMP1 = -AAPQ * D(p) / D(q) + CALL SAXPY ( M, TEMP1, WORK, 1, A(1,q), 1 ) + CALL SLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR ) + SVA(q) = AAQQ*SQRT( AMAX1( ZERO, ONE - AAPQ*AAPQ ) ) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q), SVA(p) +* recompute SVA(q), SVA(p). + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * SQRT(AAQQ) * D(q) + END IF + END IF + IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = SNRM2( M, A(1,p), 1 ) * D(p) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * SQRT(AAPP) * D(p) + END IF + SVA(p) = AAPP + END IF +* + ELSE +* A(:,p) and A(:,q) already numerically orthogonal + IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF + ELSE +* A(:,q) is zero column + IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + IF ( ir1 .EQ. 0 ) AAPP = - AAPP + NOTROT = 0 + GO TO 2103 + END IF +* + 2002 CONTINUE +* END q-LOOP +* + 2103 CONTINUE +* bailed out of q-loop + + SVA(p) = AAPP + + ELSE + SVA(p) = AAPP + IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) ) + & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p + END IF +* + 2001 CONTINUE +* end of the p-loop +* end of doing the block ( ibr, ibr ) + 1002 CONTINUE +* end of ir1-loop +* +*........................................................ +* ... go to the off diagonal blocks +* + igl = ( ibr - 1 ) * KBL + 1 +* + DO 2010 jbc = ibr + 1, NBL +* + jgl = ( jbc - 1 ) * KBL + 1 +* +* doing the block at ( ibr, jbc ) +* + IJBLSK = 0 + DO 2100 p = igl, MIN0( igl + KBL - 1, N ) +* + AAPP = SVA(p) +* + IF ( AAPP .GT. ZERO ) THEN +* + PSKIPPED = 0 +* + DO 2200 q = jgl, MIN0( jgl + KBL - 1, N ) +* + AAQQ = SVA(q) +* + IF ( AAQQ .GT. ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* -#- Safe Gram matrix computation -#- +* + IF ( AAQQ .GE. ONE ) THEN + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ) .LE. AAPP + END IF + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,p), 1, WORK, 1 ) + CALL SLASCL( 'G', 0, 0, AAPP, D(p), M, + & 1, WORK, LDA, IERR ) + AAPQ = SDOT( M, WORK, 1, A(1,q), 1 ) * + & D(q) / AAQQ + END IF + ELSE + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ .LE. ( AAPP / SMALL ) + END IF + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,q), 1, WORK, 1 ) + CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, 1, + & WORK, LDA, IERR ) + AAPQ = SDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP + END IF + END IF +* + MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) ) +* +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( ABS( AAPQ ) .GT. TOL ) THEN + NOTROT = 0 +* ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ + IF ( AAQQ .GT. AAPP0 ) THETA = - THETA +* + IF ( ABS( THETA ) .GT. BIGTHETA ) THEN + T = HALF / THETA + FASTR(3) = T * D(p) / D(q) + FASTR(4) = -T * D(q) / D(p) + CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) ) + MXSINJ = AMAX1( MXSINJ, ABS(T) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - SIGN(ONE,AAPQ) + IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN + T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) ) + CS = SQRT( ONE / ( ONE + T*T ) ) + SN = T * CS + MXSINJ = AMAX1( MXSINJ, ABS(SN) ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ) +* + APOAQ = D(p) / D(q) + AQOAP = D(q) / D(p) + IF ( D(p) .GE. ONE ) THEN +* + IF ( D(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + D(p) = D(p) * CS + D(q) = D(q) * CS + CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + IF ( RSVEC ) THEN + CALL SAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 ) + CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 ) + END IF + D(p) = D(p) * CS + D(q) = D(q) / CS + END IF + ELSE + IF ( D(q) .GE. ONE ) THEN + CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + IF ( RSVEC ) THEN + CALL SAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 ) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 ) + END IF + D(p) = D(p) / CS + D(q) = D(q) * CS + ELSE + IF ( D(p) .GE. D(q) ) THEN + CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL SAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF +* + ELSE + IF ( AAPP .GT. AAQQ ) THEN + CALL SCOPY( M, A(1,p), 1, WORK, 1 ) + CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR) + CALL SLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR) + TEMP1 = -AAPQ * D(p) / D(q) + CALL SAXPY(M,TEMP1,WORK,1,A(1,q),1) + CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR) + SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + ELSE + CALL SCOPY( M, A(1,q), 1, WORK, 1 ) + CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR) + CALL SLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR) + TEMP1 = -AAPQ * D(q) / D(p) + CALL SAXPY(M,TEMP1,WORK,1,A(1,p),1) + CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR) + SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * SQRT(AAQQ) * D(q) + END IF + END IF + IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = SNRM2( M, A(1,p), 1 ) * D(p) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * SQRT(AAPP) * D(p) + END IF + SVA(p) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF +* + IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN + SVA(p) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE +* + SVA(p) = AAPP +* + ELSE + IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1 + IF ( AAPP .LT. ZERO ) NOTROT = 0 + END IF + + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN0( igl + KBL - 1, N ) + SVA(p) = ABS(SVA(p)) + 2012 CONTINUE +* + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN + SVA(N) = SNRM2( M, A(1,N), 1 ) * D(N) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,N), 1, T, AAPP ) + SVA(N) = T * SQRT(AAPP) * D(N) + END IF +* +* Additional steering devices +* + IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + & ( ISWROT .LE. N ) ) ) + & SWBAND = i +* + IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.FLOAT(N)*TOL).AND. + & (FLOAT(N)*MXAAPQ*MXSINJ.LT.TOL))THEN + GO TO 1994 + END IF +* + IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + + 1993 CONTINUE +* end i=1:NSWEEP loop +* #:) Reaching this point means that the procedure has comleted the given +* number of iterations. + INFO = NSWEEP - 1 + GO TO 1995 + 1994 CONTINUE +* #:) Reaching this point means that during the i-th sweep all pivots were +* below the given tolerance, causing early exit. +* + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the vector D. + DO 5991 p = 1, N - 1 + q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = D(p) + D(p) = D(q) + D(q) = TEMP1 + CALL SSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + END IF + 5991 CONTINUE +* + RETURN +* .. +* .. END OF SGSVJ0 +* .. + END +* diff --git a/SRC/sgsvj1.f b/SRC/sgsvj1.f new file mode 100644 index 00000000..010f4fb0 --- /dev/null +++ b/SRC/sgsvj1.f @@ -0,0 +1,607 @@ + SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV, + & EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Zlatko Drmac of the University of Zagreb and -- +* -- Kresimir Veselic of the Fernuniversitaet Hagen -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* This routine is also part of SIGMA (version 1.23, October 23. 2008.) +* SIGMA is a library of algorithms for highly accurate algorithms for +* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the +* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0. +* +* -#- Scalar Arguments -#- +* + IMPLICIT NONE + REAL EPS, SFMIN, TOL + INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP + CHARACTER*1 JOBV +* +* -#- Array Arguments -#- +* + REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ), + & WORK( LWORK ) +* .. +* +* Purpose +* ~~~~~~~ +* SGSVJ1 is called from SGESVJ as a pre-processor and that is its main +* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but +* it targets only particular pivots and it does not check convergence +* (stopping criterion). Few tunning parameters (marked by [TP]) are +* available for the implementer. +* +* Further details +* ~~~~~~~~~~~~~~~ +* SGSVJ1 applies few sweeps of Jacobi rotations in the column space of +* the input M-by-N matrix A. The pivot pairs are taken from the (1,2) +* off-diagonal block in the corresponding N-by-N Gram matrix A^T * A. The +* block-entries (tiles) of the (1,2) off-diagonal block are marked by the +* [x]'s in the following scheme: +* +* | * * * [x] [x] [x]| +* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. +* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* +* In terms of the columns of A, the first N1 columns are rotated 'against' +* the remaining N-N1 columns, trying to increase the angle between the +* corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is +* tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter. +* The number of sweeps is given in NSWEEP and the orthogonality threshold +* is given in TOL. +* +* Contributors +* ~~~~~~~~~~~~ +* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +* +* Arguments +* ~~~~~~~~~ +* +* JOBV (input) CHARACTER*1 +* Specifies whether the output from this procedure is used +* to compute the matrix V: +* = 'V': the product of the Jacobi rotations is accumulated +* by postmulyiplying the N-by-N array V. +* (See the description of V.) +* = 'A': the product of the Jacobi rotations is accumulated +* by postmulyiplying the MV-by-N array V. +* (See the descriptions of MV and V.) +* = 'N': the Jacobi rotations are not accumulated. +* +* M (input) INTEGER +* The number of rows of the input matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the input matrix A. +* M >= N >= 0. +* +* N1 (input) INTEGER +* N1 specifies the 2 x 2 block partition, the first N1 columns are +* rotated 'against' the remaining N-N1 columns of A. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, M-by-N matrix A, such that A*diag(D) represents +* the input matrix. +* On exit, +* A_onexit * D_onexit represents the input matrix A*diag(D) +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of N1, D, TOL and NSWEEP.) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* D (input/workspace/output) REAL array, dimension (N) +* The array D accumulates the scaling factors from the fast scaled +* Jacobi rotations. +* On entry, A*diag(D) represents the input matrix. +* On exit, A_onexit*diag(D_onexit) represents the input matrix +* post-multiplied by a sequence of Jacobi rotations, where the +* rotation threshold and the total number of sweeps are given in +* TOL and NSWEEP, respectively. +* (See the descriptions of N1, A, TOL and NSWEEP.) +* +* SVA (input/workspace/output) REAL array, dimension (N) +* On entry, SVA contains the Euclidean norms of the columns of +* the matrix A*diag(D). +* On exit, SVA contains the Euclidean norms of the columns of +* the matrix onexit*diag(D_onexit). +* +* MV (input) INTEGER +* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then MV is not referenced. +* +* V (input/output) REAL array, dimension (LDV,N) +* If JOBV .EQ. 'V' then N rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a +* sequence of Jacobi rotations. +* If JOBV = 'N', then V is not referenced. +* +* LDV (input) INTEGER +* The leading dimension of the array V, LDV >= 1. +* If JOBV = 'V', LDV .GE. N. +* If JOBV = 'A', LDV .GE. MV. +* +* EPS (input) INTEGER +* EPS = SLAMCH('Epsilon') +* +* SFMIN (input) INTEGER +* SFMIN = SLAMCH('Safe Minimum') +* +* TOL (input) REAL +* TOL is the threshold for Jacobi rotations. For a pair +* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +* applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. +* +* NSWEEP (input) INTEGER +* NSWEEP is the number of sweeps of Jacobi rotations to be +* performed. +* +* WORK (workspace) REAL array, dimension LWORK. +* +* LWORK (input) INTEGER +* LWORK is the dimension of WORK. LWORK .GE. M. +* +* INFO (output) INTEGER +* = 0 : successful exit. +* < 0 : if INFO = -i, then the i-th argument had an illegal value +* +* -#- Local Parameters -#- +* + REAL ZERO, HALF, ONE, TWO + PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 ) + +* -#- Local Scalars -#- +* + REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, BIGTHETA, + & CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,ROOTEPS, ROOTSFMIN, + & ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN + INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, ISWROT, jbc, + & jgl, KBL, MVL, NOTROT, nblc, nblr, p, PSKIPPED, q, + & ROWSKIP, SWBAND + LOGICAL APPLV, ROTOK, RSVEC +* +* Local Arrays + REAL FASTR(5) +* +* Intrinsic Functions + INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT +* +* External Functions + REAL SDOT, SNRM2 + INTEGER ISAMAX + LOGICAL LSAME + EXTERNAL ISAMAX, LSAME, SDOT, SNRM2 +* +* External Subroutines + EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP +* +* + APPLV = LSAME(JOBV,'A') + RSVEC = LSAME(JOBV,'V') + IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN + INFO = -1 + ELSE IF ( M .LT. 0 ) THEN + INFO = -2 + ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN + INFO = -3 + ELSE IF ( N1 .LT. 0 ) THEN + INFO = -4 + ELSE IF ( LDA .LT. M ) THEN + INFO = -6 + ELSE IF ( MV .LT. 0 ) THEN + INFO = -9 + ELSE IF ( LDV .LT. M ) THEN + INFO = -11 + ELSE IF ( TOL .LE. EPS ) THEN + INFO = -14 + ELSE IF ( NSWEEP .LT. 0 ) THEN + INFO = -15 + ELSE IF ( LWORK .LT. M ) THEN + INFO = -17 + ELSE + INFO = 0 + END IF +* +* #:( + IF ( INFO .NE. 0 ) THEN + CALL XERBLA( 'SGSVJ1', -INFO ) + RETURN + END IF +* + IF ( RSVEC ) THEN + MVL = N + ELSE IF ( APPLV ) THEN + MVL = MV + END IF + RSVEC = RSVEC .OR. APPLV + + ROOTEPS = SQRT(EPS) + ROOTSFMIN = SQRT(SFMIN) + SMALL = SFMIN / EPS + BIG = ONE / SFMIN + ROOTBIG = ONE / ROOTSFMIN + LARGE = BIG / SQRT(FLOAT(M*N)) + BIGTHETA = ONE / ROOTEPS + ROOTTOL = SQRT(TOL) +* +* -#- Initialize the right singular vector matrix -#- +* +* RSVEC = LSAME( JOBV, 'Y' ) +* + EMPTSW = N1 * ( N - N1 ) + NOTROT = 0 + FASTR(1) = ZERO +* +* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#- +* + KBL = MIN0(8,N) + NBLR = N1 / KBL + IF ( ( NBLR * KBL ) .NE. N1 ) NBLR = NBLR + 1 + +* .. the tiling is nblr-by-nblc [tiles] + + NBLC = ( N - N1 ) / KBL + IF ( ( NBLC * KBL ) .NE. ( N - N1 ) ) NBLC = NBLC + 1 + BLSKIP = ( KBL**2 ) + 1 +*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. + + ROWSKIP = MIN0( 5, KBL ) +*[TP] ROWSKIP is a tuning parameter. + SWBAND = 0 +*[TP] SWBAND is a tuning parameter. It is meaningful and effective +* if SGESVJ is used as a computational routine in the preconditioned +* Jacobi SVD algorithm SGESVJ. +* +* +* | * * * [x] [x] [x]| +* | * * * [x] [x] [x]| Row-cycling in the nblr-by-nblc [x] blocks. +* | * * * [x] [x] [x]| Row-cyclic pivoting inside each [x] block. +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* |[x] [x] [x] * * * | +* +* + DO 1993 i = 1, NSWEEP +* .. go go go ... +* + MXAAPQ = ZERO + MXSINJ = ZERO + ISWROT = 0 +* + NOTROT = 0 + PSKIPPED = 0 +* + DO 2000 ibr = 1, NBLR + + igl = ( ibr - 1 ) * KBL + 1 +* +* +*........................................................ +* ... go to the off diagonal blocks + + igl = ( ibr - 1 ) * KBL + 1 + + DO 2010 jbc = 1, NBLC + + jgl = N1 + ( jbc - 1 ) * KBL + 1 + +* doing the block at ( ibr, jbc ) + + IJBLSK = 0 + DO 2100 p = igl, MIN0( igl + KBL - 1, N1 ) + + AAPP = SVA(p) + + IF ( AAPP .GT. ZERO ) THEN + + PSKIPPED = 0 + + DO 2200 q = jgl, MIN0( jgl + KBL - 1, N ) +* + AAQQ = SVA(q) + + IF ( AAQQ .GT. ZERO ) THEN + AAPP0 = AAPP +* +* -#- M x 2 Jacobi SVD -#- +* +* -#- Safe Gram matrix computation -#- +* + IF ( AAQQ .GE. ONE ) THEN + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = ( SMALL*AAPP ) .LE. AAQQ + ELSE + ROTOK = ( SMALL*AAQQ ) .LE. AAPP + END IF + IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN + AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,p), 1, WORK, 1 ) + CALL SLASCL( 'G', 0, 0, AAPP, D(p), M, + & 1, WORK, LDA, IERR ) + AAPQ = SDOT( M, WORK, 1, A(1,q), 1 ) * + & D(q) / AAQQ + END IF + ELSE + IF ( AAPP .GE. AAQQ ) THEN + ROTOK = AAPP .LE. ( AAQQ / SMALL ) + ELSE + ROTOK = AAQQ .LE. ( AAPP / SMALL ) + END IF + IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN + AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) * + & D(p) * D(q) / AAQQ ) / AAPP + ELSE + CALL SCOPY( M, A(1,q), 1, WORK, 1 ) + CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, 1, + & WORK, LDA, IERR ) + AAPQ = SDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP + END IF + END IF + + MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) ) + +* TO rotate or NOT to rotate, THAT is the question ... +* + IF ( ABS( AAPQ ) .GT. TOL ) THEN + NOTROT = 0 +* ROTATED = ROTATED + 1 + PSKIPPED = 0 + ISWROT = ISWROT + 1 +* + IF ( ROTOK ) THEN +* + AQOAP = AAQQ / AAPP + APOAQ = AAPP / AAQQ + THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ + IF ( AAQQ .GT. AAPP0 ) THETA = - THETA + + IF ( ABS( THETA ) .GT. BIGTHETA ) THEN + T = HALF / THETA + FASTR(3) = T * D(p) / D(q) + FASTR(4) = -T * D(q) / D(p) + CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) ) + MXSINJ = AMAX1( MXSINJ, ABS(T) ) + ELSE +* +* .. choose correct signum for THETA and rotate +* + THSIGN = - SIGN(ONE,AAPQ) + IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN + T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) ) + CS = SQRT( ONE / ( ONE + T*T ) ) + SN = T * CS + MXSINJ = AMAX1( MXSINJ, ABS(SN) ) + SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) ) + AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ) + + APOAQ = D(p) / D(q) + AQOAP = D(q) / D(p) + IF ( D(p) .GE. ONE ) THEN +* + IF ( D(q) .GE. ONE ) THEN + FASTR(3) = T * APOAQ + FASTR(4) = - T * AQOAP + D(p) = D(p) * CS + D(q) = D(q) * CS + CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR ) + IF ( RSVEC ) + & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR ) + ELSE + CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 ) + CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 ) + IF ( RSVEC ) THEN + CALL SAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 ) + CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 ) + END IF + D(p) = D(p) * CS + D(q) = D(q) / CS + END IF + ELSE + IF ( D(q) .GE. ONE ) THEN + CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 ) + CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 ) + IF ( RSVEC ) THEN + CALL SAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 ) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 ) + END IF + D(p) = D(p) / CS + D(q) = D(q) * CS + ELSE + IF ( D(p) .GE. D(q) ) THEN + CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 ) + CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 ) + D(p) = D(p) * CS + D(q) = D(q) / CS + IF ( RSVEC ) THEN + CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1) + CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1) + END IF + ELSE + CALL SAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1) + CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1) + D(p) = D(p) / CS + D(q) = D(q) * CS + IF ( RSVEC ) THEN + CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1) + CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1) + END IF + END IF + END IF + ENDIF + END IF + + ELSE + IF ( AAPP .GT. AAQQ ) THEN + CALL SCOPY( M, A(1,p), 1, WORK, 1 ) + CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR) + CALL SLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR) + TEMP1 = -AAPQ * D(p) / D(q) + CALL SAXPY(M,TEMP1,WORK,1,A(1,q),1) + CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR) + SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + ELSE + CALL SCOPY( M, A(1,q), 1, WORK, 1 ) + CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR) + CALL SLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR) + TEMP1 = -AAPQ * D(q) / D(p) + CALL SAXPY(M,TEMP1,WORK,1,A(1,p),1) + CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR) + SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ)) + MXSINJ = AMAX1( MXSINJ, SFMIN ) + END IF + END IF +* END IF ROTOK THEN ... ELSE +* +* In the case of cancellation in updating SVA(q) +* .. recompute SVA(q) + IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN + IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN + SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q) + ELSE + T = ZERO + AAQQ = ZERO + CALL SLASSQ( M, A(1,q), 1, T, AAQQ ) + SVA(q) = T * SQRT(AAQQ) * D(q) + END IF + END IF + IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN + IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN + AAPP = SNRM2( M, A(1,p), 1 ) * D(p) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,p), 1, T, AAPP ) + AAPP = T * SQRT(AAPP) * D(p) + END IF + SVA(p) = AAPP + END IF +* end of OK rotation + ELSE + NOTROT = NOTROT + 1 +* SKIPPED = SKIPPED + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + ELSE + NOTROT = NOTROT + 1 + PSKIPPED = PSKIPPED + 1 + IJBLSK = IJBLSK + 1 + END IF + +* IF ( NOTROT .GE. EMPTSW ) GO TO 2011 + IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN + SVA(p) = AAPP + NOTROT = 0 + GO TO 2011 + END IF + IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN + AAPP = -AAPP + NOTROT = 0 + GO TO 2203 + END IF + +* + 2200 CONTINUE +* end of the q-loop + 2203 CONTINUE + + SVA(p) = AAPP +* + ELSE + IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1 + IF ( AAPP .LT. ZERO ) NOTROT = 0 +*** IF ( NOTROT .GE. EMPTSW ) GO TO 2011 + END IF + + 2100 CONTINUE +* end of the p-loop + 2010 CONTINUE +* end of the jbc-loop + 2011 CONTINUE +*2011 bailed out of the jbc-loop + DO 2012 p = igl, MIN0( igl + KBL - 1, N ) + SVA(p) = ABS(SVA(p)) + 2012 CONTINUE +*** IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + 2000 CONTINUE +*2000 :: end of the ibr-loop +* +* .. update SVA(N) + IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN + SVA(N) = SNRM2( M, A(1,N), 1 ) * D(N) + ELSE + T = ZERO + AAPP = ZERO + CALL SLASSQ( M, A(1,N), 1, T, AAPP ) + SVA(N) = T * SQRT(AAPP) * D(N) + END IF +* +* Additional steering devices +* + IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. + & ( ISWROT .LE. N ) ) ) + & SWBAND = i + + IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.FLOAT(N)*TOL).AND. + & (FLOAT(N)*MXAAPQ*MXSINJ.LT.TOL))THEN + GO TO 1994 + END IF + +* + IF ( NOTROT .GE. EMPTSW ) GO TO 1994 + + 1993 CONTINUE +* end i=1:NSWEEP loop +* #:) Reaching this point means that the procedure has completed the given +* number of sweeps. + INFO = NSWEEP - 1 + GO TO 1995 + 1994 CONTINUE +* #:) Reaching this point means that during the i-th sweep all pivots were +* below the given threshold, causing early exit. + + INFO = 0 +* #:) INFO = 0 confirms successful iterations. + 1995 CONTINUE +* +* Sort the vector D +* + DO 5991 p = 1, N - 1 + q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1 + IF ( p .NE. q ) THEN + TEMP1 = SVA(p) + SVA(p) = SVA(q) + SVA(q) = TEMP1 + TEMP1 = D(p) + D(p) = D(q) + D(q) = TEMP1 + CALL SSWAP( M, A(1,p), 1, A(1,q), 1 ) + IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 ) + END IF + 5991 CONTINUE +* + RETURN +* .. +* .. END OF SGSVJ1 +* .. + END +* diff --git a/SRC/sgtcon.f b/SRC/sgtcon.f index 91911340..793608af 100644 --- a/SRC/sgtcon.f +++ b/SRC/sgtcon.f @@ -1,7 +1,7 @@ SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgtrfs.f b/SRC/sgtrfs.f index 1db55eb3..f2fac7b6 100644 --- a/SRC/sgtrfs.f +++ b/SRC/sgtrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgtsv.f b/SRC/sgtsv.f index d43066b1..c9877895 100644 --- a/SRC/sgtsv.f +++ b/SRC/sgtsv.f @@ -1,6 +1,6 @@ SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgtsvx.f b/SRC/sgtsvx.f index 61e4b48b..a3615665 100644 --- a/SRC/sgtsvx.f +++ b/SRC/sgtsvx.f @@ -2,7 +2,7 @@ $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgttrf.f b/SRC/sgttrf.f index 9ee59bcd..2ff3e656 100644 --- a/SRC/sgttrf.f +++ b/SRC/sgttrf.f @@ -1,6 +1,6 @@ SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgttrs.f b/SRC/sgttrs.f index e45c487d..07a2e64b 100644 --- a/SRC/sgttrs.f +++ b/SRC/sgttrs.f @@ -1,7 +1,7 @@ SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sgtts2.f b/SRC/sgtts2.f index 95448fdb..06ce5461 100644 --- a/SRC/sgtts2.f +++ b/SRC/sgtts2.f @@ -1,6 +1,6 @@ SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/shgeqz.f b/SRC/shgeqz.f index 2f02b6d8..52d32940 100644 --- a/SRC/shgeqz.f +++ b/SRC/shgeqz.f @@ -2,7 +2,7 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/shsein.f b/SRC/shsein.f index a2f79783..b6d26add 100644 --- a/SRC/shsein.f +++ b/SRC/shsein.f @@ -2,7 +2,7 @@ $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/shseqr.f b/SRC/shseqr.f index 5f5ee19f..1a7adbbd 100644 --- a/SRC/shseqr.f +++ b/SRC/shseqr.f @@ -1,8 +1,8 @@ SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z, $ LDZ, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK driver routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -107,9 +107,11 @@ * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. +* is sufficient and delivers very good and sometimes +* optimal performance. However, LWORK as large as 11*N +* may be required for optimal performance. A workspace +* query is recommended to determine the optimal workspace +* size. * * If LWORK = -1, then SHSEQR does a workspace query. * In this case, SHSEQR checks the input parameters and @@ -164,46 +166,50 @@ * to attain best performance in each particular * computational environment. * -* ISPEC=1: The SLAHQR vs SLAQR0 crossover point. +* ISPEC=12: The SLAHQR vs SLAQR0 crossover point. * Default: 75. (Must be at least 11.) * -* ISPEC=2: Recommended deflation window size. +* ISPEC=13: Recommended deflation window size. * This depends on ILO, IHI and NS. NS is the * number of simultaneous shifts returned -* by ILAENV(ISPEC=4). (See ISPEC=4 below.) +* by ILAENV(ISPEC=15). (See ISPEC=15 below.) * The default for (IHI-ILO+1).LE.500 is NS. * The default for (IHI-ILO+1).GT.500 is 3*NS/2. * -* ISPEC=3: Nibble crossover point. (See ILAENV for +* ISPEC=14: Nibble crossover point. (See IPARMQ for * details.) Default: 14% of deflation window * size. * -* ISPEC=4: Number of simultaneous shifts, NS, in -* a multi-shift QR iteration. +* ISPEC=15: Number of simultaneous shifts in a multishift +* QR iteration. * * If IHI-ILO+1 is ... * * greater than ...but less ... the * or equal to ... than default is * -* 1 30 NS - 2(+) -* 30 60 NS - 4(+) +* 1 30 NS = 2(+) +* 30 60 NS = 4(+) * 60 150 NS = 10(+) * 150 590 NS = ** * 590 3000 NS = 64 * 3000 6000 NS = 128 * 6000 infinity NS = 256 * -* (+) By default some or all matrices of this order +* (+) By default some or all matrices of this order * are passed to the implicit double shift routine -* SLAHQR and NS is ignored. See ISPEC=1 above -* and comments in IPARM for details. +* SLAHQR and this parameter is ignored. See +* ISPEC=12 above and comments in IPARMQ for +* details. * -* The asterisks (**) indicate an ad-hoc +* (**) The asterisks (**) indicate an ad-hoc * function of N increasing from 10 to 64. * -* ISPEC=5: Select structured matrix multiply. -* (See ILAENV for details.) Default: 3. +* ISPEC=16: Select structured matrix multiply. +* If the number of simultaneous shifts (specified +* by ISPEC=15) is less than 14, then the default +* for ISPEC=16 is 0. Otherwise the default for +* ISPEC=16 is 2. * * ================================================================ * Based on contributions by @@ -227,16 +233,15 @@ * ==== Matrices of order NTINY or smaller must be processed by * . SLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare SLAHQR failure. NL .GT. NTINY = 11 is -* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) INTEGER NL PARAMETER ( NL = 49 ) REAL ZERO, ONE @@ -341,8 +346,8 @@ * * ==== SLAHQR/SLAQR0 crossover point ==== * - NMIN = ILAENV( 1, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, - $ IHI, LWORK ) + NMIN = ILAENV( 12, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== SLAQR0 for big matrices; SLAHQR for small ones ==== diff --git a/SRC/sisnan.f b/SRC/sisnan.f index 352d70ef..d08b5696 100644 --- a/SRC/sisnan.f +++ b/SRC/sisnan.f @@ -1,12 +1,11 @@ - FUNCTION SISNAN( SIN ) - LOGICAL SISNAN + LOGICAL FUNCTION SISNAN(SIN) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. - REAL SIN + REAL SIN * .. * * Purpose @@ -29,5 +28,6 @@ EXTERNAL SLAISNAN * .. * .. Executable Statements .. - SISNAN = SLAISNAN( SIN, SIN ) - END FUNCTION + SISNAN = SLAISNAN(SIN,SIN) + RETURN + END diff --git a/SRC/sla_gbamv.f b/SRC/sla_gbamv.f new file mode 100644 index 00000000..600c0ad4 --- /dev/null +++ b/SRC/sla_gbamv.f @@ -0,0 +1,280 @@ + SUBROUTINE SLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, + $ INCX, BETA, Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS +* .. +* .. Array Arguments .. + REAL AB( LDAB, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* SLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* KL - INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU - INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* ALPHA - REAL +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - REAL array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( KL.LT.0 ) THEN + INFO = 4 + ELSE IF( KU.LT.0 ) THEN + INFO = 5 + ELSE IF( LDAB.LT.KL+KU+1 )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'SLA_GBAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + KD = KU + 1 + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( AB( KD+I-J, J ) ) + ELSE + TEMP = ABS( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( AB( KD+I-J, J ) ) + ELSE + TEMP = ABS( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of SLA_GBAMV +* + END diff --git a/SRC/sla_gbrcond.f b/SRC/sla_gbrcond.f new file mode 100644 index 00000000..bf2eda3d --- /dev/null +++ b/SRC/sla_gbrcond.f @@ -0,0 +1,215 @@ + REAL FUNCTION SLA_GBRCOND( TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, + $ IPIV, CMODE, C, INFO, WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDAB, LDAFB, INFO, KL, KU, CMODE +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), IPIV( * ) + REAL AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), + $ C( * ) +* +* SLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a real workspace of size 5*N, and +* IWORK is an integer workspace of size N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J, KD + REAL AINVNM, TMP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLACN2, SGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + SLA_GBRCOND = 0.0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') + $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLA_GBRCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + SLA_GBRCOND = 1.0 + RETURN + END IF +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + KD = KU + 1 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( KD+I-J, J ) * C( J ) ) + END IF + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( KD+I-J, J ) ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( KD+I-J, J ) / C( J ) ) + END IF + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( J, KD+I-J ) * C( J ) ) + END IF + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS(AB(J,KD+I-J)) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + ABS( AB( J, KD+I-J ) / C( J ) ) + END IF + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0 + + KASE = 0 + 10 CONTINUE + CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF ( NOTRANS ) THEN + CALL SGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL SGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( NOTRANS ) THEN + CALL SGBTRS( 'Transpose', N, KL, KU, 1, AFB, LDAFB, IPIV, + $ WORK, N, INFO ) + ELSE + CALL SGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0 ) + $ SLA_GBRCOND = ( 1.0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/sla_gbrfsx_extended.f b/SRC/sla_gbrfsx_extended.f new file mode 100644 index 00000000..2ed2d222 --- /dev/null +++ b/SRC/sla_gbrfsx_extended.f @@ -0,0 +1,303 @@ + SUBROUTINE SLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, + $ COLEQU, C, B, LDB, Y, LDY, + $ BERR_OUT, N_NORMS, ERRS_N, ERRS_C, + $ RES, AYB, DY, Y_TAIL, RCOND, + $ ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, + $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ Y( LDY, * ), RES(*), DY(*), Y_TAIL(*) + REAL C( * ), AYB(*), RCOND, BERR_OUT(*), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SCOPY, SGBTRS, SGBMV, BLAS_SGBMV_X, + $ BLAS_SGBMV2_X, SLA_GBAMV, SLA_WWADDW, SLAMCH, + $ CHLA_TRANSTYPE, SLA_LIN_BERR + REAL SLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS + M = KL+KU+1 + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL SGBMV( TRANS, M, N, KL, KU, -1.0, AB, LDAB, + $ Y( 1, J ), 1, 1.0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_SGBMV_X( TRANS_TYPE, N, N, KL, KU, + $ -1.0, AB, LDAB, Y( 1, J ), 1, 1.0, RES, 1, + $ PREC_TYPE ) + ELSE + CALL BLAS_SGBMV2_X( TRANS_TYPE, N, N, KL, KU, -1.0, + $ AB, LDAB, Y( 1, J ), Y_TAIL, 1, 1.0, RES, 1, + $ PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL SCOPY( N, RES, 1, DY, 1 ) + CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, DY, N, + $ INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( .NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL SAXPY( N, 1.0, DY, 1, Y(1,J), 1 ) + ELSE + CALL SLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL SGBMV(TRANS, N, N, KL, KU, -1.0, AB, LDAB, Y(1,J), + $ 1, 1.0, RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL SLA_GBAMV( TRANS_TYPE, N, N, KL, KU, 1.0, + $ AB, LDAB, Y(1, J), 1, 1.0, AYB, 1 ) + + CALL SLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS +* + END DO +* + RETURN + END diff --git a/SRC/sla_gbrpvgrw.f b/SRC/sla_gbrpvgrw.f new file mode 100644 index 00000000..2c623aad --- /dev/null +++ b/SRC/sla_gbrpvgrw.f @@ -0,0 +1,46 @@ + REAL FUNCTION SLA_GBRPVGRW( N, KL, KU, NCOLS, AB, LDAB, AFB, + $ LDAFB ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, KL, KU, NCOLS, LDAB, LDAFB +* .. +* .. Array Arguments .. + REAL AB( LDAB, * ), AFB( LDAFB, * ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + REAL AMAX, UMAX, RPVGRW +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0 +* + KD = KU + 1 + DO J = 1, NCOLS + AMAX = 0.0 + UMAX = 0.0 + DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) + AMAX = MAX( ABS( AB( KD+I-J, J)), AMAX ) + END DO + DO I = MAX( J-KU, 1 ), J + UMAX = MAX( ABS( AFB( KD+I-J, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + SLA_GBRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/sla_geamv.f b/SRC/sla_geamv.f new file mode 100644 index 00000000..45360469 --- /dev/null +++ b/SRC/sla_geamv.f @@ -0,0 +1,271 @@ + SUBROUTINE SLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, + $ Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N, TRANS +* .. +* .. Array Arguments .. + REAL A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* SLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - REAL +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - REAL array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL +* Array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* Level 2 Blas routine. +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'SLA_GEAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, LENX + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + JX = KX + DO J = 1, LENX + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF (.NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of SLA_GEAMV +* + END diff --git a/SRC/sla_gercond.f b/SRC/sla_gercond.f new file mode 100644 index 00000000..6279273a --- /dev/null +++ b/SRC/sla_gercond.f @@ -0,0 +1,188 @@ + REAL FUNCTION SLA_GERCOND ( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ CMODE, C, INFO, WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), + $ C( * ) +* +* SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a REAL workspace of size 3*N, and +* IWORK is an INTEGER workspace of size N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + REAL AINVNM, TMP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLACN2, SGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + SLA_GERCOND = 0.0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') + $ .AND. .NOT. LSAME(TRANS, 'C') ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLA_GERCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + SLA_GERCOND = 1.0 + RETURN + END IF +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF (NOTRANS) THEN + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, N + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0 + + KASE = 0 + 10 CONTINUE + CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK(I) = WORK(I) * WORK(2*N+I) + END DO + + IF (NOTRANS) THEN + CALL SGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL SGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF (NOTRANS) THEN + CALL SGETRS( 'Transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL SGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0 ) + $ SLA_GERCOND = ( 1.0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/sla_gerfsx_extended.f b/SRC/sla_gerfsx_extended.f new file mode 100644 index 00000000..d7494fd3 --- /dev/null +++ b/SRC/sla_gerfsx_extended.f @@ -0,0 +1,297 @@ + SUBROUTINE SLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, + $ LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, Y, LDY, BERR_OUT, N_NORMS, + $ ERRS_N, ERRS_C, RES, AYB, DY, + $ Y_TAIL, RCOND, ITHRESH, RTHRESH, + $ DZ_UB, IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SCOPY, SGETRS, SGEMV, BLAS_SGEMV_X, + $ BLAS_SGEMV2_X, SLA_GEAMV, SLA_WWADDW, SLAMCH, + $ CHLA_TRANSTYPE, SLA_LIN_BERR + REAL SLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS +* + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL SGEMV( TRANS, N, N, -1.0, A, LDA, Y( 1, J ), 1, + $ 1.0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_SGEMV_X( TRANS_TYPE, N, N, -1.0, A, LDA, + $ Y( 1, J ), 1, 1.0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_SGEMV2_X( TRANS_TYPE, N, N, -1.0, A, LDA, + $ Y( 1, J ), Y_TAIL, 1, 1.0, RES, 1, PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL SCOPY( N, RES, 1, DY, 1 ) + CALL SGETRS( TRANS, N, 1, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL +* + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL SAXPY( N, 1.0, DY, 1, Y( 1, J ), 1 ) + ELSE + CALL SLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL SGEMV( TRANS, N, N, -1.0, A, LDA, Y(1,J), 1, 1.0, RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL SLA_GEAMV ( TRANS_TYPE, N, N, 1.0, + $ A, LDA, Y(1, J), 1, 1.0, AYB, 1 ) + + CALL SLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/sla_lin_berr.f b/SRC/sla_lin_berr.f new file mode 100644 index 00000000..2ef69af3 --- /dev/null +++ b/SRC/sla_lin_berr.f @@ -0,0 +1,60 @@ + SUBROUTINE SLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NZ, NRHS +* .. +* .. Array Arguments .. + REAL AYB( N, NRHS ), BERR( NRHS ) + REAL RES( N, NRHS ) +* +* SLA_LIN_BERR computes componentwise relative backward error from +* the formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* .. +* .. Local Scalars .. + REAL TMP + INTEGER I, J +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. External Functions .. + EXTERNAL SLAMCH + REAL SLAMCH + REAL SAFE1 +* .. +* .. Executable Statements .. +* +* Adding SAFE1 to the numerator guards against spuriously zero +* residuals. A similar safeguard is in the SLA_yyAMV routine used +* to compute AYB. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (NZ+1)*SAFE1 + + DO J = 1, NRHS + BERR(J) = 0.0 + DO I = 1, N + IF (AYB(I,J) .NE. 0.0) THEN + TMP = (SAFE1+ABS(RES(I,J)))/AYB(I,J) + BERR(J) = MAX( BERR(J), TMP ) + END IF +* +* If AYB is exactly 0.0 (and if computed by SLA_yyAMV), then we know +* the true residual also must be exactly 0.0. +* + END DO + END DO + END SUBROUTINE diff --git a/SRC/sla_porcond.f b/SRC/sla_porcond.f new file mode 100644 index 00000000..4cbc6fef --- /dev/null +++ b/SRC/sla_porcond.f @@ -0,0 +1,202 @@ + REAL FUNCTION SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, CMODE, C, + $ INFO, WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO, CMODE + REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), + $ C( * ) +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) +* +* SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a real workspace of size 3*N, and +* IWORK is an integer workspace of size N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + REAL AINVNM, TMP + LOGICAL UP +* .. +* .. Array Arguments .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + EXTERNAL LSAME, ISAMAX +* .. +* .. External Subroutines .. + EXTERNAL SLACN2, SPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + SLA_PORCOND = 0.0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLA_PORCOND', -INFO ) + RETURN + END IF + + IF( N.EQ.0 ) THEN + SLA_PORCOND = 1.0 + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( J ,I ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ENDIF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0 + + KASE = 0 + 10 CONTINUE + CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF (UP) THEN + CALL SPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) + ELSE + CALL SPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( UP ) THEN + CALL SPOTRS( 'Upper', N, 1, AF, LDAF, WORK, N, INFO ) + ELSE + CALL SPOTRS( 'Lower', N, 1, AF, LDAF, WORK, N, INFO ) + ENDIF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0 ) + $ SLA_PORCOND = ( 1.0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/sla_porfsx_extended.f b/SRC/sla_porfsx_extended.f new file mode 100644 index 00000000..beff66a8 --- /dev/null +++ b/SRC/sla_porfsx_extended.f @@ -0,0 +1,297 @@ + SUBROUTINE SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, COLEQU, C, B, LDB, Y, + $ LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB(*), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, Y_PREC_STATE, BASE_RESIDUAL, + $ EXTRA_RESIDUAL, EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SCOPY, SPOTRS, SSYMV, BLAS_SSYMV_X, + $ BLAS_SSYMV2_X, SLA_SYAMV, SLA_WWADDW, + $ SLA_LIN_BERR + REAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL SSYMV( UPLO, N, -1.0, A, LDA, Y(1,J), 1, + $ 1.0, RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_SSYMV_X( UPLO2, N, -1.0, A, LDA, + $ Y( 1, J ), 1, 1.0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_SSYMV2_X(UPLO2, N, -1.0, A, LDA, + $ Y(1, J), Y_TAIL, 1, 1.0, RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL SCOPY( N, RES, 1, DY, 1 ) + CALL SPOTRS( UPLO, N, NRHS, AF, LDAF, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL SAXPY( N, 1.0, DY, 1, Y(1,J), 1 ) + ELSE + CALL SLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL SSYMV( UPLO, N, -1.0, A, LDA, Y(1,J), 1, 1.0, RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL SLA_SYAMV( UPLO2, N, 1.0, + $ A, LDA, Y(1, J), 1, 1.0, AYB, 1 ) + + CALL SLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/sla_porpvgrw.f b/SRC/sla_porpvgrw.f new file mode 100644 index 00000000..186a60a0 --- /dev/null +++ b/SRC/sla_porpvgrw.f @@ -0,0 +1,106 @@ + REAL FUNCTION SLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, LDAF, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL AMAX, UMAX, RPVGRW + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + EXTERNAL LSAME, SLASET + LOGICAL LSAME +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) +* +* SPOTRF will have factored only the NCOLSxNCOLS leading minor, so +* we restrict the growth search to that minor and use only the first +* 2*NCOLS workspace entries. +* + RPVGRW = 1.0 + DO I = 1, 2*NCOLS + WORK( I ) = 0.0 + END DO +* +* Find the max magnitude entry of each column. +* + IF ( UPPER ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( NCOLS+J ) = + $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( NCOLS+J ) = + $ MAX( ABS( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of the factor in +* AF. No pivoting, so no permutations. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( J ) = MAX( ABS( AF( I, J ) ), WORK( J ) ) + END DO + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + SLA_PORPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/sla_rpvgrw.f b/SRC/sla_rpvgrw.f new file mode 100644 index 00000000..161c9f4b --- /dev/null +++ b/SRC/sla_rpvgrw.f @@ -0,0 +1,44 @@ + REAL FUNCTION SLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AF( LDAF, * ) +* .. +* .. Local Scalars .. + INTEGER I, J + REAL AMAX, UMAX, RPVGRW +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0 +* + DO J = 1, NCOLS + AMAX = 0.0 + UMAX = 0.0 + DO I = 1, N + AMAX = MAX( ABS( A( I, J ) ), AMAX ) + END DO + DO I = 1, J + UMAX = MAX( ABS( AF( I, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + SLA_RPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/sla_syamv.f b/SRC/sla_syamv.f new file mode 100644 index 00000000..280cd86f --- /dev/null +++ b/SRC/sla_syamv.f @@ -0,0 +1,275 @@ + SUBROUTINE SLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER INCX, INCY, LDA, N, UPLO +* .. +* .. Array Arguments .. + REAL A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* SLA_SYAMV performs the matrix-vector operation +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* n by n symmetric matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* UPLO - INTEGER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = BLAS_UPPER Only the upper triangular part of A +* is to be referenced. +* +* UPLO = BLAS_LOWER Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - REAL . +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - REAL array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - REAL . +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - REAL array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCY ) ) +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* -- Modified for the absolute-value product, April 2006 +* Jason Riedy, UC Berkeley +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + REAL TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SLAMCH + REAL SLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) ) THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'SSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = SLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = ABS( A( I, J ) ) + ELSE + TEMP = ABS( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*ABS( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of SLA_SYAMV +* + END diff --git a/SRC/sla_syrcond.f b/SRC/sla_syrcond.f new file mode 100644 index 00000000..d410831f --- /dev/null +++ b/SRC/sla_syrcond.f @@ -0,0 +1,205 @@ + REAL FUNCTION SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, CMODE, + $ C, INFO, WORK, IWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO, CMODE +* .. +* .. Array Arguments + INTEGER IWORK( * ), IPIV( * ) + REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * ) +* +* SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) +* where op2 is determined by CMODE as follows +* CMODE = 1 op2(C) = C +* CMODE = 0 op2(C) = I +* CMODE = -1 op2(C) = inv(C) +* The Skeel condition number cond(A) = norminf( |inv(A)||A| ) +* is computed by computing scaling factors R such that +* diag(R)*A*op2(C) is row equilibrated and computing the standard +* infinity-norm condition number. +* WORK is a real workspace of size 3*N, and +* IWORK is an integer workspace of size N. +* .. +* .. Local Scalars .. + CHARACTER NORMIN + INTEGER KASE, I, J + REAL AINVNM, SMLNUM, TMP + LOGICAL UP +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + REAL SLAMCH + EXTERNAL LSAME, ISAMAX, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA, SSYTRS +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Executable Statements .. +* + SLA_SYRCOND = 0.0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLA_SYRCOND', -INFO ) + RETURN + END IF + IF( N.EQ.0 ) THEN + SLA_SYRCOND = 1.0 + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute the equilibration matrix R such that +* inv(R)*A*C has unit 1-norm. +* + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( J, I ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( J, I ) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( I, J ) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ELSE + DO I = 1, N + TMP = 0.0 + IF ( CMODE .EQ. 1 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) * C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) * C( J ) ) + END DO + ELSE IF ( CMODE .EQ. 0 ) THEN + DO J = 1, I + TMP = TMP + ABS( A( I, J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I ) ) + END DO + ELSE + DO J = 1, I + TMP = TMP + ABS( A( I, J) / C( J ) ) + END DO + DO J = I+1, N + TMP = TMP + ABS( A( J, I) / C( J ) ) + END DO + END IF + WORK( 2*N+I ) = TMP + END DO + ENDIF +* +* Estimate the norm of inv(op(A)). +* + SMLNUM = SLAMCH( 'Safe minimum' ) + AINVNM = 0.0 + NORMIN = 'N' + + KASE = 0 + 10 CONTINUE + CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + + IF ( UP ) THEN + call ssytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) + ELSE + call ssytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CMODE .EQ. 1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) / C( I ) + END DO + ELSE IF ( CMODE .EQ. -1 ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + + IF ( UP ) THEN + call ssytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) + ELSE + call ssytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) + ENDIF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * WORK( 2*N+I ) + END DO + END IF +* + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0 ) + $ SLA_SYRCOND = ( 1.0 / AINVNM ) +* + RETURN +* + END diff --git a/SRC/sla_syrfsx_extended.f b/SRC/sla_syrfsx_extended.f new file mode 100644 index 00000000..5671bebf --- /dev/null +++ b/SRC/sla_syrfsx_extended.f @@ -0,0 +1,297 @@ + SUBROUTINE SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + REAL RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE + REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, Y_PREC_STATE, BASE_RESIDUAL, + $ EXTRA_RESIDUAL, EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL SAXPY, SCOPY, SSYTRS, SSYMV, BLAS_SSYMV_X, + $ BLAS_SSYMV2_X, SLA_SYAMV, SLA_WWADDW, + $ SLA_LIN_BERR + REAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + EPS = SLAMCH( 'Epsilon' ) + HUGEVAL = SLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = REAL( N )*EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + DXRAT = 0.0 + DXRATMAX = 0.0 + DZRAT = 0.0 + DZRATMAX = 0.0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + IF (Y_PREC_STATE .EQ. BASE_RESIDUAL) THEN + CALL SSYMV( UPLO, N, -1.0, A, LDA, Y(1,J), 1, + $ 1.0, RES, 1 ) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_SSYMV_X( UPLO2, N, -1.0, A, LDA, + $ Y( 1, J ), 1, 1.0, RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_SSYMV2_X(UPLO2, N, -1.0, A, LDA, + $ Y(1, J), Y_TAIL, 1, 1.0, RES, 1, PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL SCOPY( N, RES, 1, DY, 1 ) + CALL SSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0 + NORMY = 0.0 + NORMDX = 0.0 + DZ_Z = 0.0 + YMIN = HUGEVAL + + DO I = 1, N + YK = ABS( Y( I, J ) ) + DYK = ABS( DY( I ) ) + + IF ( YK .NE. 0.0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF ( NORMX .NE. 0.0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0 ) THEN + DX_X = 0.0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL SAXPY( N, 1.0, DY, 1, Y(1,J), 1 ) + ELSE + CALL SLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). + CALL SCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL SSYMV( UPLO, N, -1.0, A, LDA, Y(1,J), 1, 1.0, RES, 1 ) + + DO I = 1, N + AYB( I ) = ABS( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL SLA_SYAMV( UPLO2, N, 1.0, + $ A, LDA, Y(1, J), 1, 1.0, AYB, 1 ) + + CALL SLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/sla_syrpvgrw.f b/SRC/sla_syrpvgrw.f new file mode 100644 index 00000000..d10cab9e --- /dev/null +++ b/SRC/sla_syrpvgrw.f @@ -0,0 +1,201 @@ + REAL FUNCTION SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, + $ WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AF( LDAF, * ), WORK( * ) +* .. +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + REAL AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Functions .. + EXTERNAL LSAME, SLASET + LOGICAL LSAME +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF ( UPPER ) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0 + DO I = 1, 2*N + WORK( I ) = 0.0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( ABS( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( ABS( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from ssytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = MAX( ABS( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( ABS( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = MAX( ABS( AF(I, K+1 ) ), WORK( K+1 ) ) + END DO + WORK( K ) = MAX( ABS( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + SLA_SYRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/sla_wwaddw.f b/SRC/sla_wwaddw.f new file mode 100644 index 00000000..e173d2c2 --- /dev/null +++ b/SRC/sla_wwaddw.f @@ -0,0 +1,53 @@ + SUBROUTINE SLA_WWADDW( N, X, Y, W ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N +* .. +* .. Array Arguments .. + REAL X( * ), Y( * ), W( * ) +* .. +* +* Purpose +* ======= +* +* SLA_WWADDW adds a vector W into a doubled-single vector (X, Y). +* +* This works for all extant IBM's hex and binary floating point +* arithmetics, but not for decimal. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The length of vectors X, Y, and W. +* +* X, Y (input/output) REAL array, length N +* The doubled-single accumulation vector. +* +* W (input) REAL array, length N +* The vector to be added. +* .. +* .. Local Scalars .. + REAL S + INTEGER I +* .. +* .. Executable Statements .. +* + DO 10 I = 1, N + S = X(I) + W(I) + S = (S + S) - S + Y(I) = ((X(I) - S) + W(I)) + Y(I) + X(I) = S + 10 CONTINUE + RETURN + END diff --git a/SRC/slabad.f b/SRC/slabad.f index 6de6a312..4b6157f0 100644 --- a/SRC/slabad.f +++ b/SRC/slabad.f @@ -1,6 +1,6 @@ SUBROUTINE SLABAD( SMALL, LARGE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slabrd.f b/SRC/slabrd.f index c11b23e0..7688cbc5 100644 --- a/SRC/slabrd.f +++ b/SRC/slabrd.f @@ -1,7 +1,7 @@ SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slacn2.f b/SRC/slacn2.f index 7ee6a41d..6ddcf114 100644 --- a/SRC/slacn2.f +++ b/SRC/slacn2.f @@ -1,6 +1,6 @@ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slacon.f b/SRC/slacon.f index 1d50b5f6..bcb9e059 100644 --- a/SRC/slacon.f +++ b/SRC/slacon.f @@ -1,6 +1,6 @@ SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slacpy.f b/SRC/slacpy.f index 993705d1..8066dbfa 100644 --- a/SRC/slacpy.f +++ b/SRC/slacpy.f @@ -1,6 +1,6 @@ SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sladiv.f b/SRC/sladiv.f index f487d55c..3f501f6b 100644 --- a/SRC/sladiv.f +++ b/SRC/sladiv.f @@ -1,6 +1,6 @@ SUBROUTINE SLADIV( A, B, C, D, P, Q ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slae2.f b/SRC/slae2.f index beb45950..17e8abc0 100644 --- a/SRC/slae2.f +++ b/SRC/slae2.f @@ -1,6 +1,6 @@ SUBROUTINE SLAE2( A, B, C, RT1, RT2 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaebz.f b/SRC/slaebz.f index 82af82af..f8b442ac 100644 --- a/SRC/slaebz.f +++ b/SRC/slaebz.f @@ -2,7 +2,7 @@ $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, $ NAB, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed0.f b/SRC/slaed0.f index a4844214..62a98420 100644 --- a/SRC/slaed0.f +++ b/SRC/slaed0.f @@ -1,7 +1,7 @@ SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, $ WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed1.f b/SRC/slaed1.f index a18a550f..d40cfd40 100644 --- a/SRC/slaed1.f +++ b/SRC/slaed1.f @@ -1,7 +1,7 @@ SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed2.f b/SRC/slaed2.f index 2731c84b..9263f12f 100644 --- a/SRC/slaed2.f +++ b/SRC/slaed2.f @@ -1,7 +1,7 @@ SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W, $ Q2, INDX, INDXC, INDXP, COLTYP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed3.f b/SRC/slaed3.f index 83a56689..1a9a507f 100644 --- a/SRC/slaed3.f +++ b/SRC/slaed3.f @@ -1,7 +1,7 @@ SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX, $ CTOT, W, S, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed4.f b/SRC/slaed4.f index dbb1e202..55a089f0 100644 --- a/SRC/slaed4.f +++ b/SRC/slaed4.f @@ -1,6 +1,6 @@ SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed5.f b/SRC/slaed5.f index 20332b8d..23b37359 100644 --- a/SRC/slaed5.f +++ b/SRC/slaed5.f @@ -1,6 +1,6 @@ SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed6.f b/SRC/slaed6.f index 03464628..5e1465c8 100644 --- a/SRC/slaed6.f +++ b/SRC/slaed6.f @@ -1,6 +1,6 @@ SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * February 2007 * diff --git a/SRC/slaed7.f b/SRC/slaed7.f index f8979c80..645da421 100644 --- a/SRC/slaed7.f +++ b/SRC/slaed7.f @@ -3,7 +3,7 @@ $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed8.f b/SRC/slaed8.f index 4ee41f74..8ba4f268 100644 --- a/SRC/slaed8.f +++ b/SRC/slaed8.f @@ -2,7 +2,7 @@ $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR, $ GIVCOL, GIVNUM, INDXP, INDX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaed9.f b/SRC/slaed9.f index 86cfb6fb..5af58de2 100644 --- a/SRC/slaed9.f +++ b/SRC/slaed9.f @@ -1,7 +1,7 @@ SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W, $ S, LDS, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaeda.f b/SRC/slaeda.f index 7039ff52..0290e5cc 100644 --- a/SRC/slaeda.f +++ b/SRC/slaeda.f @@ -1,7 +1,7 @@ SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR, $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaein.f b/SRC/slaein.f index d7d634d4..08bd2aed 100644 --- a/SRC/slaein.f +++ b/SRC/slaein.f @@ -1,7 +1,7 @@ SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B, $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaev2.f b/SRC/slaev2.f index 965cf601..f69572d3 100644 --- a/SRC/slaev2.f +++ b/SRC/slaev2.f @@ -1,6 +1,6 @@ SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaexc.f b/SRC/slaexc.f index bbc16798..d07e55a9 100644 --- a/SRC/slaexc.f +++ b/SRC/slaexc.f @@ -1,7 +1,7 @@ SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slag2.f b/SRC/slag2.f index 94f6fd60..7da1d1fa 100644 --- a/SRC/slag2.f +++ b/SRC/slag2.f @@ -1,7 +1,7 @@ SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, $ WR2, WI ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slag2d.f b/SRC/slag2d.f index d8081651..b43699c2 100644 --- a/SRC/slag2d.f +++ b/SRC/slag2d.f @@ -1,21 +1,16 @@ - SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO) + SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO ) * -* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) -- +* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* January 2007 +* August 2007 * * .. -* .. WARNING: PROTOTYPE .. -* This is an LAPACK PROTOTYPE routine which means that the -* interface of this routine is likely to be changed in the future -* based on community feedback. -* * .. Scalar Arguments .. - INTEGER INFO,LDA,LDSA,M,N + INTEGER INFO, LDA, LDSA, M, N * .. * .. Array Arguments .. - REAL SA(LDSA,*) - DOUBLE PRECISION A(LDA,*) + REAL SA( LDSA, * ) + DOUBLE PRECISION A( LDA, * ) * .. * * Purpose @@ -24,11 +19,11 @@ * SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE * PRECISION matrix, A. * -* Note that while it is possible to overflow while converting +* Note that while it is possible to overflow while converting * from double to single, it is not possible to overflow when -* converting from single to double. +* converting from single to double. * -* This is a helper routine so there is no argument checking. +* This is an auxiliary routine so there is no argument checking. * * Arguments * ========= @@ -39,14 +34,14 @@ * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * -* SA (output) REAL array, dimension (LDSA,N) -* On exit, the M-by-N coefficient matrix SA. +* SA (input) REAL array, dimension (LDSA,N) +* On entry, the M-by-N coefficient matrix SA. * * LDSA (input) INTEGER * The leading dimension of the array SA. LDSA >= max(1,M). * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N coefficient matrix A. +* A (output) DOUBLE PRECISION array, dimension (LDA,N) +* On exit, the M-by-N coefficient matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). @@ -56,15 +51,15 @@ * ========= * * .. Local Scalars .. - INTEGER I,J + INTEGER I, J * .. * .. Executable Statements .. * INFO = 0 - DO 20 J = 1,N - DO 30 I = 1,M - A(I,J) = SA(I,J) - 30 CONTINUE + DO 20 J = 1, N + DO 10 I = 1, M + A( I, J ) = SA( I, J ) + 10 CONTINUE 20 CONTINUE RETURN * diff --git a/SRC/slags2.f b/SRC/slags2.f index 8c224864..8a3505f0 100644 --- a/SRC/slags2.f +++ b/SRC/slags2.f @@ -1,7 +1,7 @@ SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slagtf.f b/SRC/slagtf.f index fb5df58c..4f933e84 100644 --- a/SRC/slagtf.f +++ b/SRC/slagtf.f @@ -1,6 +1,6 @@ SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slagtm.f b/SRC/slagtm.f index cd58ceef..5ec5db07 100644 --- a/SRC/slagtm.f +++ b/SRC/slagtm.f @@ -1,7 +1,7 @@ SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slagts.f b/SRC/slagts.f index e2f43bee..c3b51a71 100644 --- a/SRC/slagts.f +++ b/SRC/slagts.f @@ -1,6 +1,6 @@ SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slagv2.f b/SRC/slagv2.f index bfe2f4d9..1f52c73e 100644 --- a/SRC/slagv2.f +++ b/SRC/slagv2.f @@ -1,7 +1,7 @@ SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL, $ CSR, SNR ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slahqr.f b/SRC/slahqr.f index e1259705..1737f679 100644 --- a/SRC/slahqr.f +++ b/SRC/slahqr.f @@ -1,8 +1,8 @@ SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -118,11 +118,10 @@ * * 12-04 Further modifications by * Ralph Byers, University of Kansas, USA -* -* This is a modified version of SLAHQR from LAPACK version 3.0. -* It is (1) more robust against overflow and underflow and -* (2) adopts the more conservative Ahues & Tisseur stopping -* criterion (LAWN 122, 1997). +* This is a modified version of SLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). * * ========================================================= * @@ -265,10 +264,20 @@ I2 = I END IF * - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN + IF( ITS.EQ.10 ) THEN +* +* Exceptional shift. +* + S = ABS( H( L+1, L ) ) + ABS( H( L+2, L+1 ) ) + H11 = DAT1*S + H( L, L ) + H12 = DAT2*S + H21 = S + H22 = H11 + ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * + S = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) ) H11 = DAT1*S + H( I, I ) H12 = DAT2*S H21 = S @@ -373,7 +382,11 @@ IF( K.LT.I-1 ) $ H( K+2, K-1 ) = ZERO ELSE IF( M.GT.L ) THEN - H( K, K-1 ) = -H( K, K-1 ) +* ==== Use the following instead of +* . H( K, K-1 ) = -H( K, K-1 ) to +* . avoid a bug when v(2) and v(3) +* . underflow. ==== + H( K, K-1 ) = H( K, K-1 )*( ONE-T1 ) END IF V2 = V( 2 ) T2 = T1*V2 diff --git a/SRC/slahr2.f b/SRC/slahr2.f index 4f8bf2ac..0bf73d12 100644 --- a/SRC/slahr2.f +++ b/SRC/slahr2.f @@ -1,6 +1,6 @@ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slahrd.f b/SRC/slahrd.f index b5163a73..8d04e21a 100644 --- a/SRC/slahrd.f +++ b/SRC/slahrd.f @@ -1,6 +1,6 @@ SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaic1.f b/SRC/slaic1.f index 78f161ff..3cf62d17 100644 --- a/SRC/slaic1.f +++ b/SRC/slaic1.f @@ -1,6 +1,6 @@ SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaisnan.f b/SRC/slaisnan.f index ac4a8024..ef87fbdc 100644 --- a/SRC/slaisnan.f +++ b/SRC/slaisnan.f @@ -1,12 +1,11 @@ - FUNCTION SLAISNAN( SIN1, SIN2 ) - LOGICAL SLAISNAN + LOGICAL FUNCTION SLAISNAN(SIN1,SIN2) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. - REAL SIN1, SIN2 + REAL SIN1,SIN2 * .. * * Purpose @@ -37,4 +36,5 @@ * * .. Executable Statements .. SLAISNAN = (SIN1.NE.SIN2) - END FUNCTION + RETURN + END diff --git a/SRC/slaln2.f b/SRC/slaln2.f index 37422804..5cd7c84c 100644 --- a/SRC/slaln2.f +++ b/SRC/slaln2.f @@ -1,7 +1,7 @@ SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B, $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slals0.f b/SRC/slals0.f index 336a0265..bb0ab39e 100644 --- a/SRC/slals0.f +++ b/SRC/slals0.f @@ -2,7 +2,7 @@ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slalsa.f b/SRC/slalsa.f index 3dd606bd..9ef0860f 100644 --- a/SRC/slalsa.f +++ b/SRC/slalsa.f @@ -3,7 +3,7 @@ $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slalsd.f b/SRC/slalsd.f index 49e0ac25..e52dcb19 100644 --- a/SRC/slalsd.f +++ b/SRC/slalsd.f @@ -1,7 +1,7 @@ SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slamrg.f b/SRC/slamrg.f index a2b554a6..fc8c337a 100644 --- a/SRC/slamrg.f +++ b/SRC/slamrg.f @@ -1,6 +1,6 @@ SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaneg.f b/SRC/slaneg.f index c9d91e2b..6c262c25 100644 --- a/SRC/slaneg.f +++ b/SRC/slaneg.f @@ -2,7 +2,7 @@ IMPLICIT NONE INTEGER SLANEG * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slangb.f b/SRC/slangb.f index dd9d8ae9..ecea0a72 100644 --- a/SRC/slangb.f +++ b/SRC/slangb.f @@ -1,7 +1,7 @@ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slange.f b/SRC/slange.f index c7c122ee..a3c895f3 100644 --- a/SRC/slange.f +++ b/SRC/slange.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slangt.f b/SRC/slangt.f index efd701f7..dc56c605 100644 --- a/SRC/slangt.f +++ b/SRC/slangt.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slanhs.f b/SRC/slanhs.f index 6c3e370e..b61f2f9c 100644 --- a/SRC/slanhs.f +++ b/SRC/slanhs.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slansb.f b/SRC/slansb.f index 04f8ec04..d9fef615 100644 --- a/SRC/slansb.f +++ b/SRC/slansb.f @@ -1,7 +1,7 @@ REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slansf.f b/SRC/slansf.f new file mode 100644 index 00000000..98272fb8 --- /dev/null +++ b/SRC/slansf.f @@ -0,0 +1,861 @@ + REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM, TRANSR, UPLO + INTEGER N +* .. +* .. Array Arguments .. + REAL A( 0: * ), WORK( 0: * ) +* .. +* +* Purpose +* ======= +* +* SLANSF returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* real symmetric matrix A in RFP format. +* +* Description +* =========== +* +* SLANSF returns the value +* +* SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER +* Specifies the value to be returned in SLANSF as described +* above. +* +* TRANSR (input) CHARACTER +* Specifies whether the RFP format of A is normal or +* transposed format. +* = 'N': RFP format is Normal; +* = 'T': RFP format is Transpose. +* +* UPLO (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* = 'U': RFP A came from an upper triangular matrix; +* = 'L': RFP A came from a lower triangular matrix. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, SLANSF is +* set to zero. +* +* A (input) REAL array, dimension ( N*(N+1)/2 ); +* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') +* part of the symmetric matrix A stored in RFP format. See the +* "Notes" below for more details. +* Unchanged on exit. +* +* WORK (workspace) REAL array, dimension (MAX(1,LWORK)), +* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +* WORK is not referenced. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA + REAL SCALE, S, VALUE, AA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ISAMAX + EXTERNAL LSAME, ISAMAX +* .. +* .. External Subroutines .. + EXTERNAL SLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + SLANSF = ZERO + RETURN + END IF +* +* set noe = 1 if n is odd. if n is even set noe=0 +* + NOE = 1 + IF( MOD( N, 2 ).EQ.0 ) + + NOE = 0 +* +* set ifm = 0 when form='T or 't' and 1 otherwise +* + IFM = 1 + IF( LSAME( TRANSR, 'T' ) ) + + IFM = 0 +* +* set ilu = 0 when uplo='U or 'u' and 1 otherwise +* + ILU = 1 + IF( LSAME( UPLO, 'U' ) ) + + ILU = 0 +* +* set lda = (n+1)/2 when ifm = 0 +* set lda = n when ifm = 1 and noe = 1 +* set lda = n+1 when ifm = 1 and noe = 0 +* + IF( IFM.EQ.1 ) THEN + IF( NOE.EQ.1 ) THEN + LDA = N + ELSE +* noe=0 + LDA = N + 1 + END IF + ELSE +* ifm=0 + LDA = ( N+1 ) / 2 + END IF +* + IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + K = ( N+1 ) / 2 + VALUE = ZERO + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is n by k + DO J = 0, K - 1 + DO I = 0, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* xpose case; A is k by n + DO J = 0, N - 1 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is n+1 by k + DO J = 0, K - 1 + DO I = 0, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* xpose case; A is k by n+1 + DO J = 0, N + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + END IF + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + + ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + IF( IFM.EQ.1 ) THEN + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd + IF( ILU.EQ.0 ) THEN + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + IF( I.EQ.K+K ) + + GO TO 10 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + 10 CONTINUE + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + IF( J.GT.0 ) THEN + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + END IF + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even + IF( ILU.EQ.0 ) THEN + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + ELSE +* ifm=0 + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd + IF( ILU.EQ.0 ) THEN + N1 = K +* n/2 + K = K + 1 +* k is the row size and lda + DO I = N1, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, N1 - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,n1+i) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=n1=k-1 is special + S = ABS( A( 0+J*LDA ) ) +* A(k-1,k-1) + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,i+n1) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K, N - 1 + S = ZERO + DO I = 0, J - K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-k + AA = ABS( A( I+J*LDA ) ) +* A(j-k,j-k) + S = S + AA + WORK( J-K ) = WORK( J-K ) + S + I = I + 1 + S = ABS( A( I+J*LDA ) ) +* A(j,j) + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 2 +* process + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* i=j so process of A(j,j) + S = S + AA + WORK( J ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( A( I+J*LDA ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k-1 is special :process col A(k-1,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K, N - 1 +* process col j of A = A(j,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even + IF( ILU.EQ.0 ) THEN + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i+k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=k + AA = ABS( A( 0+J*LDA ) ) +* A(k,k) + S = AA + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k,k+i) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K + 1, N - 1 + S = ZERO + DO I = 0, J - 2 - K + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-1-k + AA = ABS( A( I+J*LDA ) ) +* A(j-k-1,j-k-1) + S = S + AA + WORK( J-K-1 ) = WORK( J-K-1 ) + S + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,j) + S = AA + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO +* j=n + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(i,k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = WORK( I ) + S + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO +* j=0 is special :process col A(k:n-1,k) + S = ABS( A( 0 ) ) +* A(k,k) + DO I = 1, K - 1 + AA = ABS( A( I ) ) +* A(k+i,k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( K ) = WORK( K ) + S + DO J = 1, K - 1 +* process + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( A( I+J*LDA ) ) +* i=j-1 so process of A(j-1,j-1) + S = S + AA + WORK( J-1 ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( A( I+J*LDA ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k is special :process col A(k,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K + 1, N +* process col j-1 of A = A(j-1,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J-1 ) = WORK( J-1 ) + S + END DO + I = ISAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + K = ( N+1 ) / 2 + SCALE = ZERO + S = ONE + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 3 + CALL SLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) +* L at A(k,0) + END DO + DO J = 0, K - 1 + CALL SLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K-1, A( K ), LDA+1, SCALE, S ) +* tri L at A(k,0) + CALL SLASSQ( K, A( K-1 ), LDA+1, SCALE, S ) +* tri U at A(k-1,0) + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL SLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* trap L at A(0,0) + END DO + DO J = 0, K - 2 + CALL SLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri L at A(0,0) + CALL SLASSQ( K-1, A( 0+LDA ), LDA+1, SCALE, S ) +* tri U at A(0,1) + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 2 + CALL SLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) +* U at A(0,k) + END DO + DO J = 0, K - 2 + CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL SLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, + + SCALE, S ) +* L at A(0,k-1) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K-1, A( 0+K*LDA ), LDA+1, SCALE, S ) +* tri U at A(0,k) + CALL SLASSQ( K, A( 0+( K-1 )*LDA ), LDA+1, SCALE, S ) +* tri L at A(0,k-1) + ELSE +* A' is lower + DO J = 1, K - 1 + CALL SLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + DO J = K, N - 1 + CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,k) + END DO + DO J = 0, K - 3 + CALL SLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) +* L at A(1,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + CALL SLASSQ( K-1, A( 1 ), LDA+1, SCALE, S ) +* tri L at A(1,0) + END IF + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 2 + CALL SLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) +* L at A(k+1,0) + END DO + DO J = 0, K - 1 + CALL SLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K, A( K+1 ), LDA+1, SCALE, S ) +* tri L at A(k+1,0) + CALL SLASSQ( K, A( K ), LDA+1, SCALE, S ) +* tri U at A(k,0) + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL SLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) +* trap L at A(1,0) + END DO + DO J = 1, K - 1 + CALL SLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K, A( 1 ), LDA+1, SCALE, S ) +* tri L at A(1,0) + CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 1 + CALL SLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) +* U at A(0,k+1) + END DO + DO J = 0, K - 1 + CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL SLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, + + S ) +* L at A(0,k) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K, A( 0+( K+1 )*LDA ), LDA+1, SCALE, S ) +* tri U at A(0,k+1) + CALL SLASSQ( K, A( 0+K*LDA ), LDA+1, SCALE, S ) +* tri L at A(0,k) + ELSE +* A' is lower + DO J = 1, K - 1 + CALL SLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + DO J = K + 1, N + CALL SLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,k+1) + END DO + DO J = 0, K - 2 + CALL SLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* L at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + CALL SLASSQ( K, A( LDA ), LDA+1, SCALE, S ) +* tri L at A(0,1) + CALL SLASSQ( K, A( 0 ), LDA+1, SCALE, S ) +* tri U at A(0,0) + END IF + END IF + END IF + VALUE = SCALE*SQRT( S ) + END IF +* + SLANSF = VALUE + RETURN +* +* End of SLANSF +* + END diff --git a/SRC/slansp.f b/SRC/slansp.f index a0a86958..1ac43874 100644 --- a/SRC/slansp.f +++ b/SRC/slansp.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slanst.f b/SRC/slanst.f index 836752ec..1e1503cc 100644 --- a/SRC/slanst.f +++ b/SRC/slanst.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANST( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slansy.f b/SRC/slansy.f index ae260306..417f67fc 100644 --- a/SRC/slansy.f +++ b/SRC/slansy.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slantb.f b/SRC/slantb.f index 8ba88926..2d9c9f90 100644 --- a/SRC/slantb.f +++ b/SRC/slantb.f @@ -1,7 +1,7 @@ REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slantp.f b/SRC/slantp.f index 329e2270..6c32fb63 100644 --- a/SRC/slantp.f +++ b/SRC/slantp.f @@ -1,6 +1,6 @@ REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slantr.f b/SRC/slantr.f index 8573310a..ba667daa 100644 --- a/SRC/slantr.f +++ b/SRC/slantr.f @@ -1,7 +1,7 @@ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slanv2.f b/SRC/slanv2.f index c301a2c2..b0ca1173 100644 --- a/SRC/slanv2.f +++ b/SRC/slanv2.f @@ -1,6 +1,6 @@ SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slapll.f b/SRC/slapll.f index 0f502aba..95f7febf 100644 --- a/SRC/slapll.f +++ b/SRC/slapll.f @@ -1,6 +1,6 @@ SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slapmt.f b/SRC/slapmt.f index 1f24536b..e7d7aec9 100644 --- a/SRC/slapmt.f +++ b/SRC/slapmt.f @@ -1,6 +1,6 @@ SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slapy2.f b/SRC/slapy2.f index 0eac04fe..a5f66222 100644 --- a/SRC/slapy2.f +++ b/SRC/slapy2.f @@ -1,6 +1,6 @@ REAL FUNCTION SLAPY2( X, Y ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slapy3.f b/SRC/slapy3.f index f5db3853..309fdb7d 100644 --- a/SRC/slapy3.f +++ b/SRC/slapy3.f @@ -1,6 +1,6 @@ REAL FUNCTION SLAPY3( X, Y, Z ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqgb.f b/SRC/slaqgb.f index 181d83ae..adba83f4 100644 --- a/SRC/slaqgb.f +++ b/SRC/slaqgb.f @@ -1,7 +1,7 @@ SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqge.f b/SRC/slaqge.f index b3d87f26..d9df9ec6 100644 --- a/SRC/slaqge.f +++ b/SRC/slaqge.f @@ -1,7 +1,7 @@ SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqp2.f b/SRC/slaqp2.f index ce47cb62..5052c4a7 100644 --- a/SRC/slaqp2.f +++ b/SRC/slaqp2.f @@ -1,7 +1,7 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqps.f b/SRC/slaqps.f index f71adf47..1f83fb1a 100644 --- a/SRC/slaqps.f +++ b/SRC/slaqps.f @@ -1,7 +1,7 @@ SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqr0.f b/SRC/slaqr0.f index c79d2f28..f840e389 100644 --- a/SRC/slaqr0.f +++ b/SRC/slaqr0.f @@ -1,8 +1,8 @@ SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -73,7 +73,7 @@ * WR (output) REAL array, dimension (IHI) * WI (output) REAL array, dimension (IHI) * The real and imaginary parts, respectively, of the computed -* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) +* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) * and WI(ILO:IHI). If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with @@ -174,20 +174,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . SLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== REAL WILK1, WILK2 PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 ) REAL ZERO, ONE @@ -197,9 +200,9 @@ REAL AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -225,24 +228,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use SLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use SLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -257,6 +245,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -266,7 +267,6 @@ NWR = ILAENV( 13, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -317,6 +317,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -355,50 +356,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. - $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/slaqr1.f b/SRC/slaqr1.f index c7bdaa0f..4ba1f57f 100644 --- a/SRC/slaqr1.f +++ b/SRC/slaqr1.f @@ -1,7 +1,7 @@ SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. diff --git a/SRC/slaqr2.f b/SRC/slaqr2.f index beeaee64..c1335ac8 100644 --- a/SRC/slaqr2.f +++ b/SRC/slaqr2.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -82,7 +82,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) REAL array, dimension (LDZ,IHI) +* Z (input/output) REAL array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the orthogonal * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -157,7 +157,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) @@ -176,7 +176,7 @@ * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR, - $ SLANV2, SLARF, SLARFG, SLASET, SORGHR, STREXC + $ SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT @@ -195,9 +195,10 @@ CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to SORGHR ==== +* ==== Workspace query call to SORMHR ==== * - CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== @@ -216,6 +217,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -255,6 +257,7 @@ IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -332,7 +335,7 @@ NS = NS - 2 ELSE * -* ==== Undflatable. Move them up out of the way. +* ==== Undeflatable. Move them up out of the way. * . Fortunately, STREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * @@ -478,18 +481,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of SORGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL SLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/slaqr3.f b/SRC/slaqr3.f index 33b05d7c..a7c6eb0e 100644 --- a/SRC/slaqr3.f +++ b/SRC/slaqr3.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -78,7 +78,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) REAL array, dimension (LDZ,IHI) +* Z (input/output) REAL array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the orthogonal * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -153,7 +153,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) @@ -173,7 +173,7 @@ * .. * .. External Subroutines .. EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR, - $ SLANV2, SLAQR4, SLARF, SLARFG, SLASET, SORGHR, + $ SLANV2, SLAQR4, SLARF, SLARFG, SLASET, SORMHR, $ STREXC * .. * .. Intrinsic Functions .. @@ -193,9 +193,10 @@ CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to SORGHR ==== +* ==== Workspace query call to SORMHR ==== * - CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to SLAQR4 ==== @@ -220,6 +221,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -259,6 +261,7 @@ IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -342,7 +345,7 @@ NS = NS - 2 ELSE * -* ==== Undflatable. Move them up out of the way. +* ==== Undeflatable. Move them up out of the way. * . Fortunately, STREXC does the right thing with * . ILST in case of a rare exchange failure. ==== * @@ -488,18 +491,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of SORGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL SLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/slaqr4.f b/SRC/slaqr4.f index 306d1522..1a05898c 100644 --- a/SRC/slaqr4.f +++ b/SRC/slaqr4.f @@ -1,8 +1,8 @@ SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -80,7 +80,7 @@ * WR (output) REAL array, dimension (IHI) * WI (output) REAL array, dimension (IHI) * The real and imaginary parts, respectively, of the computed -* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI) +* eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) * and WI(ILO:IHI). If two eigenvalues are computed as a * complex conjugate pair, they are stored in consecutive * elements of WR and WI, say the i-th and (i+1)th, with @@ -181,20 +181,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . SLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constants WILK1 and WILK2 are used to form the +* . exceptional shifts. ==== REAL WILK1, WILK2 PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 ) REAL ZERO, ONE @@ -204,9 +207,9 @@ REAL AA, BB, CC, CS, DD, SN, SS, SWAP INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -232,24 +235,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use SLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use SLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -264,6 +252,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -273,7 +274,6 @@ NWR = ILAENV( 13, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -324,6 +324,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -362,50 +363,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. - $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( ABS( H( KWTOP, KWTOP-1 ) ).GT. + $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/slaqr5.f b/SRC/slaqr5.f index 8b144bb1..55ebbbfa 100644 --- a/SRC/slaqr5.f +++ b/SRC/slaqr5.f @@ -2,7 +2,7 @@ $ SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, $ LDU, NV, WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -58,11 +58,12 @@ * NSHFTS gives the number of simultaneous shifts. NSHFTS * must be positive and even. * -* SR (input) REAL array of size (NSHFTS) -* SI (input) REAL array of size (NSHFTS) +* SR (input/output) REAL array of size (NSHFTS) +* SI (input/output) REAL array of size (NSHFTS) * SR contains the real parts and SI contains the imaginary * parts of the NSHFTS shifts of origin that define the -* multi-shift QR sweep. +* multi-shift QR sweep. On output SR and SI may be +* reordered. * * H (input/output) REAL array of size (LDH,N) * On input H contains a Hessenberg matrix. On output a @@ -123,13 +124,12 @@ * LDWV is the leading dimension of WV as declared in the * in the calling subroutine. LDWV.GE.NV. * -* * ================================================================ * Based on contributions by * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ============================================================ +* ================================================================ * Reference: * * K. Braman, R. Byers and R. Mathias, The Multi-Shift QR @@ -137,7 +137,7 @@ * Level 3 Performance, SIAM Journal of Matrix Analysis, * volume 23, pages 929--947, 2002. * -* ============================================================ +* ================================================================ * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) @@ -200,7 +200,7 @@ END IF 10 CONTINUE * -* ==== NSHFTS is supposed to be even, but if is odd, +* ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. The shuffle above * . ensures that the dropped shift is real and that * . the remaining shifts are paired. ==== @@ -289,19 +289,12 @@ CALL SLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant -* . deflation or destructive underflow. (The -* . initial bulge is always collapsed.) Use -* . the two-small-subdiagonals trick to try -* . to get it started again. If V(2,M).NE.0 and -* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then -* . this bulge is collapsing into a zero -* . subdiagonal. It will be restarted next -* . trip through the loop.) -* - IF( V( 1, M ).NE.ZERO .AND. - $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, - $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) - $ THEN +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * @@ -311,46 +304,31 @@ ELSE * * ==== Atypical case: collapsed. Attempt to -* . reintroduce ignoring H(K+1,K). If the -* . fill resulting from the new reflector -* . is too large, then abandon it. +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL SLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ), $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ), $ VT ) - SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) + - $ ABS( VT( 3 ) ) - IF( SCL.NE.ZERO ) THEN - VT( 1 ) = VT( 1 ) / SCL - VT( 2 ) = VT( 2 ) / SCL - VT( 3 ) = VT( 3 ) / SCL - END IF + ALPHA = VT( 1 ) + CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* + $ H( K+2, K ) ) * -* ==== The following is the traditional and -* . conservative two-small-subdiagonals -* . test. ==== -* . - IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+ - $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )* + IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would -* . create non-negligible fill. If -* . the old reflector is diagonal (only -* . possible with underflows), then -* . change it to I. Otherwise, use -* . it with trepidation. ==== -* - IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) - $ THEN - V( 1, M ) = ZERO - ELSE - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - END IF +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would @@ -358,11 +336,7 @@ * . Replace the old reflector with * . the new one. ==== * - ALPHA = VT( 1 ) - CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) + - $ H( K+3, K )*VT( 3 ) - H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) @@ -390,12 +364,6 @@ H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF - ELSE -* -* ==== Initialize V(1,M22) here to avoid possible undefined -* . variable problems later. ==== -* - V( 1, M22 ) = ZERO END IF * * ==== Multiply H by reflections from the left ==== @@ -529,7 +497,7 @@ * . criteria both be satisfied. The latter improves * . accuracy in some examples. Falling back on an * . alternate convergence criterion when TST1 or TST2 -* . is zero (as done here) is traditional but probably +* . is zero (as done here) is traditional but probably * . unnecessary. ==== * IF( H( K+1, K ).NE.ZERO ) THEN @@ -682,7 +650,7 @@ CALL SGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * -* ==== Copy top of H bottom of WH ==== +* ==== Copy top of H to bottom of WH ==== * CALL SLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) diff --git a/SRC/slaqsb.f b/SRC/slaqsb.f index 807af554..6c0fdcf9 100644 --- a/SRC/slaqsb.f +++ b/SRC/slaqsb.f @@ -1,6 +1,6 @@ SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqsp.f b/SRC/slaqsp.f index 40ed3965..50b128ea 100644 --- a/SRC/slaqsp.f +++ b/SRC/slaqsp.f @@ -1,6 +1,6 @@ SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqsy.f b/SRC/slaqsy.f index 864cbedf..ede3388e 100644 --- a/SRC/slaqsy.f +++ b/SRC/slaqsy.f @@ -1,6 +1,6 @@ SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaqtr.f b/SRC/slaqtr.f index abd1d0af..cce27e58 100644 --- a/SRC/slaqtr.f +++ b/SRC/slaqtr.f @@ -1,7 +1,7 @@ SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slar1v.f b/SRC/slar1v.f index 85364a96..474a1230 100644 --- a/SRC/slar1v.f +++ b/SRC/slar1v.f @@ -2,7 +2,7 @@ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slar2v.f b/SRC/slar2v.f index 4dcceb32..5af94609 100644 --- a/SRC/slar2v.f +++ b/SRC/slar2v.f @@ -1,6 +1,6 @@ SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarf.f b/SRC/slarf.f index 018f6a88..04866d55 100644 --- a/SRC/slarf.f +++ b/SRC/slarf.f @@ -1,7 +1,7 @@ SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarfb.f b/SRC/slarfb.f index 8f503be9..5299dfe8 100644 --- a/SRC/slarfb.f +++ b/SRC/slarfb.f @@ -2,7 +2,7 @@ $ T, LDT, C, LDC, WORK, LDWORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarfg.f b/SRC/slarfg.f index 9f74e7b5..b5f905cb 100644 --- a/SRC/slarfg.f +++ b/SRC/slarfg.f @@ -1,6 +1,6 @@ SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarfp.f b/SRC/slarfp.f index c40e32ef..af6ab63a 100644 --- a/SRC/slarfp.f +++ b/SRC/slarfp.f @@ -1,6 +1,6 @@ SUBROUTINE SLARFP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarft.f b/SRC/slarft.f index 879e710d..87798777 100644 --- a/SRC/slarft.f +++ b/SRC/slarft.f @@ -1,7 +1,7 @@ SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -234,13 +234,13 @@ * CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF END IF T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF END IF 40 CONTINUE END IF diff --git a/SRC/slarfx.f b/SRC/slarfx.f index e712d8ae..bf8028d9 100644 --- a/SRC/slarfx.f +++ b/SRC/slarfx.f @@ -1,6 +1,6 @@ SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slargv.f b/SRC/slargv.f index e75e3152..d9f479b7 100644 --- a/SRC/slargv.f +++ b/SRC/slargv.f @@ -1,6 +1,6 @@ SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarnv.f b/SRC/slarnv.f index 99928623..4b018a2c 100644 --- a/SRC/slarnv.f +++ b/SRC/slarnv.f @@ -1,6 +1,6 @@ SUBROUTINE SLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarra.f b/SRC/slarra.f index 5cef365f..660aca18 100644 --- a/SRC/slarra.f +++ b/SRC/slarra.f @@ -2,7 +2,7 @@ $ NSPLIT, ISPLIT, INFO ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrb.f b/SRC/slarrb.f index 4edce688..b0314935 100644 --- a/SRC/slarrb.f +++ b/SRC/slarrb.f @@ -2,7 +2,7 @@ $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, TWIST, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrc.f b/SRC/slarrc.f index 015e7bc3..a4b109f0 100644 --- a/SRC/slarrc.f +++ b/SRC/slarrc.f @@ -1,7 +1,7 @@ SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, $ EIGCNT, LCNT, RCNT, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrd.f b/SRC/slarrd.f index 2a20429b..70c3ff03 100644 --- a/SRC/slarrd.f +++ b/SRC/slarrd.f @@ -3,7 +3,7 @@ $ M, W, WERR, WL, WU, IBLOCK, INDEXW, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarre.f b/SRC/slarre.f index a7978e2d..f3773023 100644 --- a/SRC/slarre.f +++ b/SRC/slarre.f @@ -4,7 +4,7 @@ $ WORK, IWORK, INFO ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrf.f b/SRC/slarrf.f index 529e4e70..f84f771e 100644 --- a/SRC/slarrf.f +++ b/SRC/slarrf.f @@ -3,7 +3,7 @@ $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, $ DPLUS, LPLUS, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 ** diff --git a/SRC/slarrj.f b/SRC/slarrj.f index 48fda3a3..69054bd7 100644 --- a/SRC/slarrj.f +++ b/SRC/slarrj.f @@ -2,7 +2,7 @@ $ RTOL, OFFSET, W, WERR, WORK, IWORK, $ PIVMIN, SPDIAM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrk.f b/SRC/slarrk.f index 3b12e06d..550b3e11 100644 --- a/SRC/slarrk.f +++ b/SRC/slarrk.f @@ -2,7 +2,7 @@ $ D, E2, PIVMIN, RELTOL, W, WERR, INFO) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrr.f b/SRC/slarrr.f index c6e2d20b..54dbaa2d 100644 --- a/SRC/slarrr.f +++ b/SRC/slarrr.f @@ -1,6 +1,6 @@ SUBROUTINE SLARRR( N, D, E, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarrv.f b/SRC/slarrv.f index d93d44e9..838f86c6 100644 --- a/SRC/slarrv.f +++ b/SRC/slarrv.f @@ -4,7 +4,7 @@ $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarscl2.f b/SRC/slarscl2.f new file mode 100644 index 00000000..01a72a64 --- /dev/null +++ b/SRC/slarscl2.f @@ -0,0 +1,55 @@ + SUBROUTINE SLARSCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + REAL D( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* SLARSCL2 performs a reciprocal diagonal scaling on an vector: +* x <-- inv(D) * x +* where the diagonal matrix D is stored as a vector. +* +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) REAL array, length N +* Diagonal matrix D, stored as a vector of length N. +* +* X (input/output) REAL array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) / D(I) + END DO + END DO +* + RETURN + END diff --git a/SRC/slartg.f b/SRC/slartg.f index 4388075b..87dfa312 100644 --- a/SRC/slartg.f +++ b/SRC/slartg.f @@ -1,6 +1,6 @@ SUBROUTINE SLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slartv.f b/SRC/slartv.f index 95d2f810..03d71564 100644 --- a/SRC/slartv.f +++ b/SRC/slartv.f @@ -1,6 +1,6 @@ SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaruv.f b/SRC/slaruv.f index cf505ee2..936b9aed 100644 --- a/SRC/slaruv.f +++ b/SRC/slaruv.f @@ -1,6 +1,6 @@ SUBROUTINE SLARUV( ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarz.f b/SRC/slarz.f index 1c7d948e..005e64f1 100644 --- a/SRC/slarz.f +++ b/SRC/slarz.f @@ -1,6 +1,6 @@ SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarzb.f b/SRC/slarzb.f index 5d55e753..cc1a8515 100644 --- a/SRC/slarzb.f +++ b/SRC/slarzb.f @@ -1,7 +1,7 @@ SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slarzt.f b/SRC/slarzt.f index 1b29aa30..e81ed162 100644 --- a/SRC/slarzt.f +++ b/SRC/slarzt.f @@ -1,6 +1,6 @@ SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slas2.f b/SRC/slas2.f index 6e3ab07a..b850a4bb 100644 --- a/SRC/slas2.f +++ b/SRC/slas2.f @@ -1,6 +1,6 @@ SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slascl.f b/SRC/slascl.f index ee3a4713..d6bb376c 100644 --- a/SRC/slascl.f +++ b/SRC/slascl.f @@ -1,6 +1,6 @@ SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slascl2.f b/SRC/slascl2.f new file mode 100644 index 00000000..1435a86f --- /dev/null +++ b/SRC/slascl2.f @@ -0,0 +1,55 @@ + SUBROUTINE SLASCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + REAL D( * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* SLASCL2 performs a diagonal scaling on a vector: +* x <-- D * x +* where the diagonal matrix D is stored as a vector. +* +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) REAL array, length N +* Diagonal matrix D, stored as a vector of length N. +* +* X (input/output) REAL array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) * D(I) + END DO + END DO +* + RETURN + END diff --git a/SRC/slasd0.f b/SRC/slasd0.f index 996d25cf..e95178c0 100644 --- a/SRC/slasd0.f +++ b/SRC/slasd0.f @@ -1,7 +1,7 @@ SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, $ WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd1.f b/SRC/slasd1.f index 86cddeeb..a016ee1c 100644 --- a/SRC/slasd1.f +++ b/SRC/slasd1.f @@ -1,7 +1,7 @@ SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, $ IDXQ, IWORK, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd2.f b/SRC/slasd2.f index f7e8048d..0fb13afe 100644 --- a/SRC/slasd2.f +++ b/SRC/slasd2.f @@ -2,7 +2,7 @@ $ LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, $ IDXC, IDXQ, COLTYP, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd3.f b/SRC/slasd3.f index 77cf6d3f..470552e4 100644 --- a/SRC/slasd3.f +++ b/SRC/slasd3.f @@ -2,7 +2,7 @@ $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd4.f b/SRC/slasd4.f index 0cd7e428..82320665 100644 --- a/SRC/slasd4.f +++ b/SRC/slasd4.f @@ -1,6 +1,6 @@ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd5.f b/SRC/slasd5.f index 4442f2fc..7ce52aae 100644 --- a/SRC/slasd5.f +++ b/SRC/slasd5.f @@ -1,6 +1,6 @@ SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd6.f b/SRC/slasd6.f index c211aae3..22356208 100644 --- a/SRC/slasd6.f +++ b/SRC/slasd6.f @@ -3,7 +3,7 @@ $ LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, $ IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd7.f b/SRC/slasd7.f index a8e67b34..6b9b2693 100644 --- a/SRC/slasd7.f +++ b/SRC/slasd7.f @@ -3,7 +3,7 @@ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ C, S, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasd8.f b/SRC/slasd8.f index b32ffa2c..3b6838b6 100644 --- a/SRC/slasd8.f +++ b/SRC/slasd8.f @@ -1,9 +1,9 @@ SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, $ DSIGMA, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* October 2006 * * .. Scalar Arguments .. INTEGER ICOMPQ, INFO, K, LDDIFR @@ -42,9 +42,10 @@ * D (output) REAL array, dimension ( K ) * On output, D contains the updated singular values. * -* Z (input) REAL array, dimension ( K ) -* The first K elements of this array contain the components -* of the deflation-adjusted updating row vector. +* Z (input/output) REAL array, dimension ( K ) +* On entry, the first K elements of this array contain the +* components of the deflation-adjusted updating row vector. +* On exit, Z is updated. * * VF (input/output) REAL array, dimension ( K ) * On entry, VF contains information passed through DBEDE8. @@ -73,10 +74,12 @@ * LDDIFR (input) INTEGER * The leading dimension of DIFR, must be at least K. * -* DSIGMA (input) REAL array, dimension ( K ) -* The first K elements of this array contain the old roots -* of the deflated updating problem. These are the poles +* DSIGMA (input/output) REAL array, dimension ( K ) +* On entry, the first K elements of this array contain the old +* roots of the deflated updating problem. These are the poles * of the secular equation. +* On exit, the elements of DSIGMA may be very slightly altered +* in value. * * WORK (workspace) REAL array, dimension at least 3 * K * @@ -156,7 +159,7 @@ * changes the bottommost bits of DSIGMA(I). It does not account * for hexadecimal or decimal machines without guard digits * (we know of none). We use a subroutine call to compute -* 2*DSIGMA(I) to prevent optimizing compilers from eliminating +* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating * this code. * DO 10 I = 1, K @@ -251,3 +254,4 @@ * End of SLASD8 * END + diff --git a/SRC/slasda.f b/SRC/slasda.f index 5092f92a..e29a6a0c 100644 --- a/SRC/slasda.f +++ b/SRC/slasda.f @@ -2,7 +2,7 @@ $ DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, $ PERM, GIVNUM, C, S, WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasdq.f b/SRC/slasdq.f index 596cf676..2fe6f83e 100644 --- a/SRC/slasdq.f +++ b/SRC/slasdq.f @@ -1,7 +1,7 @@ SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, $ U, LDU, C, LDC, WORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasdt.f b/SRC/slasdt.f index 335935c0..e3328c8f 100644 --- a/SRC/slasdt.f +++ b/SRC/slasdt.f @@ -1,6 +1,6 @@ SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaset.f b/SRC/slaset.f index 7acc0cad..65d5fe37 100644 --- a/SRC/slaset.f +++ b/SRC/slaset.f @@ -1,6 +1,6 @@ SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasq1.f b/SRC/slasq1.f index bc8a2f1e..5a063a7c 100644 --- a/SRC/slasq1.f +++ b/SRC/slasq1.f @@ -1,8 +1,14 @@ SUBROUTINE SLASQ1( N, D, E, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER INFO, N diff --git a/SRC/slasq2.f b/SRC/slasq2.f index 9fd6fa01..05c3e7cb 100644 --- a/SRC/slasq2.f +++ b/SRC/slasq2.f @@ -1,10 +1,14 @@ SUBROUTINE SLASQ2( N, Z, INFO ) * -* -- LAPACK routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- * -* Modified to call SLAZQ3 in place of SLASQ3, 13 Feb 03, SJH. +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER INFO, N @@ -30,7 +34,7 @@ * Note : SLASQ2 defines a logical variable, IEEE, which is true * on machines which follow ieee-754 floating-point standard in their * handling of infinities and NaNs, and false otherwise. This variable -* is passed to SLAZQ3. +* is passed to SLASQ3. * * Arguments * ========= @@ -38,7 +42,7 @@ * N (input) INTEGER * The number of rows and columns in the matrix. N >= 0. * -* Z (workspace) REAL array, dimension (4*N) +* Z (input/output) REAL array, dimension ( 4*N ) * On entry Z holds the qd array. On exit, entries 1 to N hold * the eigenvalues in decreasing order, Z( 2*N+1 ) holds the * trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If @@ -76,14 +80,15 @@ * .. * .. Local Scalars .. LOGICAL IEEE - INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, - $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE - REAL D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E, - $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN, - $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX + INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K, + $ KMIN, N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE + REAL D, DEE, DEEMIN, DESIG, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, E, EMAX, EMIN, EPS, G, OLDEMN, QMAX, + $ QMIN, S, SAFMIN, SIGMA, T, TAU, TEMP, TOL, + $ TOL2, TRACE, ZMAX * .. * .. External Subroutines .. - EXTERNAL SLAZQ3, SLASRT, XERBLA + EXTERNAL SLASQ3, SLASRT, XERBLA * .. * .. External Functions .. INTEGER ILAENV @@ -206,8 +211,13 @@ * * Check whether the machine is IEEE conformable. * - IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. - $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 +* IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. +* $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 +* +* [11/15/2008] The case IEEE=.TRUE. has a problem in single precision with +* some the test matrices of type 16. The double precision code is fine. +* + IEEE = .FALSE. * * Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). * @@ -287,7 +297,7 @@ PP = 1 - PP 80 CONTINUE * -* Initialise variables to pass to SLAZQ3 +* Initialise variables to pass to SLASQ3. * TTYPE = 0 DMIN1 = ZERO @@ -295,15 +305,16 @@ DN = ZERO DN1 = ZERO DN2 = ZERO + G = ZERO TAU = ZERO * ITER = 2 NFAIL = 0 NDIV = 2*( N0-I0 ) * - DO 140 IWHILA = 1, N + 1 + DO 160 IWHILA = 1, N + 1 IF( N0.LT.1 ) - $ GO TO 150 + $ GO TO 170 * * While array unfinished do * @@ -346,29 +357,60 @@ * 100 CONTINUE I0 = I4 / 4 -* -* Store EMIN for passing to SLAZQ3. -* - Z( 4*N0-1 ) = EMIN + PP = 0 +* + IF( N0-I0.GT.1 ) THEN + DEE = Z( 4*I0-3 ) + DEEMIN = DEE + KMIN = I0 + DO 110 I4 = 4*I0+1, 4*N0-3, 4 + DEE = Z( I4 )*( DEE /( DEE+Z( I4-2 ) ) ) + IF( DEE.LE.DEEMIN ) THEN + DEEMIN = DEE + KMIN = ( I4+3 )/4 + END IF + 110 CONTINUE + IF( (KMIN-I0)*2.LT.N0-KMIN .AND. + $ DEEMIN.LE.HALF*Z(4*N0-3) ) THEN + IPN4 = 4*( I0+N0 ) + PP = 2 + DO 120 I4 = 4*I0, 2*( I0+N0-1 ), 4 + TEMP = Z( I4-3 ) + Z( I4-3 ) = Z( IPN4-I4-3 ) + Z( IPN4-I4-3 ) = TEMP + TEMP = Z( I4-2 ) + Z( I4-2 ) = Z( IPN4-I4-2 ) + Z( IPN4-I4-2 ) = TEMP + TEMP = Z( I4-1 ) + Z( I4-1 ) = Z( IPN4-I4-5 ) + Z( IPN4-I4-5 ) = TEMP + TEMP = Z( I4 ) + Z( I4 ) = Z( IPN4-I4-4 ) + Z( IPN4-I4-4 ) = TEMP + 120 CONTINUE + END IF + END IF * * Put -(initial shift) into DMIN. * DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) ) * -* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. -* - PP = 0 +* Now I0:N0 is unreduced. +* PP = 0 for ping, PP = 1 for pong. +* PP = 2 indicates that flipping was applied to the Z array and +* and that the tests for deflation upon entry in SLASQ3 +* should not be performed. * NBIG = 30*( N0-I0+1 ) - DO 120 IWHILB = 1, NBIG + DO 140 IWHILB = 1, NBIG IF( I0.GT.N0 ) - $ GO TO 130 + $ GO TO 150 * * While submatrix unfinished take a good dqds step. * - CALL SLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, + CALL SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU ) + $ DN2, G, TAU ) * PP = 1 - PP * @@ -381,7 +423,7 @@ QMAX = Z( 4*I0-3 ) EMIN = Z( 4*I0-1 ) OLDEMN = Z( 4*I0 ) - DO 110 I4 = 4*I0, 4*( N0-3 ), 4 + DO 130 I4 = 4*I0, 4*( N0-3 ), 4 IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR. $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN Z( I4-1 ) = -SIGMA @@ -394,45 +436,45 @@ EMIN = MIN( EMIN, Z( I4-1 ) ) OLDEMN = MIN( OLDEMN, Z( I4 ) ) END IF - 110 CONTINUE + 130 CONTINUE Z( 4*N0-1 ) = EMIN Z( 4*N0 ) = OLDEMN I0 = SPLT + 1 END IF END IF * - 120 CONTINUE + 140 CONTINUE * INFO = 2 RETURN * * end IWHILB * - 130 CONTINUE + 150 CONTINUE * - 140 CONTINUE + 160 CONTINUE * INFO = 3 RETURN * * end IWHILA * - 150 CONTINUE + 170 CONTINUE * * Move q's to the front. * - DO 160 K = 2, N + DO 180 K = 2, N Z( K ) = Z( 4*K-3 ) - 160 CONTINUE + 180 CONTINUE * * Sort and compute sum of eigenvalues. * CALL SLASRT( 'D', N, Z, IINFO ) * E = ZERO - DO 170 K = N, 1, -1 + DO 190 K = N, 1, -1 E = E + Z( K ) - 170 CONTINUE + 190 CONTINUE * * Store trace, sum(eigenvalues) and information on performance. * diff --git a/SRC/slasq3.f b/SRC/slasq3.f index e72dde33..d74cdb64 100644 --- a/SRC/slasq3.f +++ b/SRC/slasq3.f @@ -1,14 +1,22 @@ SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE ) + $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, + $ DN2, G, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. LOGICAL IEEE INTEGER I0, ITER, N0, NDIV, NFAIL, PP - REAL DESIG, DMIN, QMAX, SIGMA + REAL DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, + $ QMAX, SIGMA, TAU * .. * .. Array Arguments .. REAL Z( * ) @@ -33,8 +41,11 @@ * Z (input) REAL array, dimension ( 4*N ) * Z holds the qd array. * -* PP (input) INTEGER +* PP (input/output) INTEGER * PP=0 for ping, PP=1 for pong. +* PP=2 indicates that flipping was applied to the Z array +* and that the initial tests for deflation should not be +* performed. * * DMIN (output) REAL * Minimum value of d. @@ -57,12 +68,16 @@ * NDIV (output) INTEGER * Number of divisions. * -* TTYPE (output) INTEGER -* Shift type. -* * IEEE (input) LOGICAL * Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). * +* TTYPE (input/output) INTEGER +* Shift type. +* +* DMIN1, DMIN2, DN, DN1, DN2, G, TAU (input/output) REAL +* These are passed as arguments in order to save their values +* between calls to SLASQ3. +* * ===================================================================== * * .. Parameters .. @@ -74,33 +89,23 @@ * .. * .. Local Scalars .. INTEGER IPN4, J4, N0IN, NN, TTYPE - REAL DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T, - $ TAU, TEMP, TOL, TOL2 + REAL EPS, S, T, TEMP, TOL, TOL2 * .. * .. External Subroutines .. EXTERNAL SLASQ4, SLASQ5, SLASQ6 * .. * .. External Function .. REAL SLAMCH - EXTERNAL SLAMCH + LOGICAL SISNAN + EXTERNAL SISNAN, SLAMCH * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT * .. -* .. Save statement .. - SAVE TTYPE - SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU -* .. -* .. Data statement .. - DATA TTYPE / 0 / - DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /, - $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO / -* .. * .. Executable Statements .. * N0IN = N0 EPS = SLAMCH( 'Precision' ) - SAFMIN = SLAMCH( 'Safe minimum' ) TOL = EPS*HUNDRD TOL2 = TOL**2 * @@ -162,6 +167,8 @@ GO TO 10 * 50 CONTINUE + IF( PP.EQ.2 ) + $ PP = 0 * * Reverse the qd-array, if warranted. * @@ -196,88 +203,88 @@ END IF END IF * - IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), - $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN -* -* Choose a shift. +* Choose a shift. * - CALL SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE ) + CALL SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, + $ DN2, TAU, TTYPE, G ) * -* Call dqds until DMIN > 0. +* Call dqds until DMIN > 0. * - 80 CONTINUE + 70 CONTINUE * - CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE ) + CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, + $ DN1, DN2, IEEE ) * - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 + NDIV = NDIV + ( N0-I0+2 ) + ITER = ITER + 1 * -* Check status. +* Check status. * - IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN + IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN * -* Success. +* Success. * - GO TO 100 + GO TO 90 * - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. - $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. - $ ABS( DN ).LT.TOL*SIGMA ) THEN + ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. + $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. + $ ABS( DN ).LT.TOL*SIGMA ) THEN * -* Convergence hidden by negative DN. +* Convergence hidden by negative DN. * - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 100 - ELSE IF( DMIN.LT.ZERO ) THEN + Z( 4*( N0-1 )-PP+2 ) = ZERO + DMIN = ZERO + GO TO 90 + ELSE IF( DMIN.LT.ZERO ) THEN * -* TAU too big. Select new TAU and try again. +* TAU too big. Select new TAU and try again. * - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN + NFAIL = NFAIL + 1 + IF( TTYPE.LT.-22 ) THEN * -* Failed twice. Play it safe. +* Failed twice. Play it safe. * - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN + TAU = ZERO + ELSE IF( DMIN1.GT.ZERO ) THEN * -* Late failure. Gives excellent shift. +* Late failure. Gives excellent shift. * - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE + TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) + TTYPE = TTYPE - 11 + ELSE * -* Early failure. Divide by 4. +* Early failure. Divide by 4. * - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 80 - ELSE IF( DMIN.NE.DMIN ) THEN + TAU = QURTR*TAU + TTYPE = TTYPE - 12 + END IF + GO TO 70 + ELSE IF( SISNAN( DMIN ) ) THEN * -* NaN. +* NaN. * - TAU = ZERO + IF( TAU.EQ.ZERO ) THEN GO TO 80 ELSE -* -* Possible underflow. Play it safe. -* - GO TO 90 + TAU = ZERO + GO TO 70 END IF + ELSE +* +* Possible underflow. Play it safe. +* + GO TO 80 END IF * * Risk of underflow. * - 90 CONTINUE + 80 CONTINUE CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) NDIV = NDIV + ( N0-I0+2 ) ITER = ITER + 1 TAU = ZERO * - 100 CONTINUE + 90 CONTINUE IF( TAU.LT.SIGMA ) THEN DESIG = DESIG + TAU T = SIGMA + DESIG diff --git a/SRC/slasq4.f b/SRC/slasq4.f index 1c4bc62e..bf378f81 100644 --- a/SRC/slasq4.f +++ b/SRC/slasq4.f @@ -1,13 +1,19 @@ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE ) + $ DN1, DN2, TAU, TTYPE, G ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER I0, N0, N0IN, PP, TTYPE - REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU + REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU * .. * .. Array Arguments .. REAL Z( * ) @@ -16,7 +22,7 @@ * Purpose * ======= * -* SLASQ4 computes an approximation TAU to the smallest eigenvalue +* SLASQ4 computes an approximation TAU to the smallest eigenvalue * using values of d from the previous transform. * * I0 (input) INTEGER @@ -31,7 +37,7 @@ * PP (input) INTEGER * PP=0 for ping, PP=1 for pong. * -* N0IN (input) INTEGER +* NOIN (input) INTEGER * The value of N0 at start of EIGTEST. * * DMIN (input) REAL @@ -58,6 +64,10 @@ * TTYPE (output) INTEGER * Shift type. * +* G (input/output) REAL +* G is passed as an argument in order to save its value between +* calls to SLASQ4. +* * Further Details * =============== * CNST1 = 9/16 @@ -75,17 +85,11 @@ * .. * .. Local Scalars .. INTEGER I4, NN, NP - REAL A2, B1, B2, G, GAM, GAP1, GAP2, S + REAL A2, B1, B2, GAM, GAP1, GAP2, S * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT * .. -* .. Save statement .. - SAVE G -* .. -* .. Data statement .. - DATA G / ZERO / -* .. * .. Executable Statements .. * * A negative DMIN forces the shift to take that absolute value diff --git a/SRC/slasq5.f b/SRC/slasq5.f index 64669582..d785312a 100644 --- a/SRC/slasq5.f +++ b/SRC/slasq5.f @@ -1,9 +1,15 @@ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2, IEEE ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. LOGICAL IEEE diff --git a/SRC/slasq6.f b/SRC/slasq6.f index f09d8cff..109237f8 100644 --- a/SRC/slasq6.f +++ b/SRC/slasq6.f @@ -1,9 +1,15 @@ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, $ DNM1, DNM2 ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Osni Marques of the Lawrence Berkeley National -- +* -- Laboratory and Beresford Parlett of the Univ. of California at -- +* -- Berkeley -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * * .. Scalar Arguments .. INTEGER I0, N0, PP diff --git a/SRC/slasr.f b/SRC/slasr.f index 651d9a47..4dafc8a6 100644 --- a/SRC/slasr.f +++ b/SRC/slasr.f @@ -1,6 +1,6 @@ SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasrt.f b/SRC/slasrt.f index a6188c06..1ee51e01 100644 --- a/SRC/slasrt.f +++ b/SRC/slasrt.f @@ -1,6 +1,6 @@ SUBROUTINE SLASRT( ID, N, D, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slassq.f b/SRC/slassq.f index e69b3a8c..22d2604e 100644 --- a/SRC/slassq.f +++ b/SRC/slassq.f @@ -1,6 +1,6 @@ SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasv2.f b/SRC/slasv2.f index a8717302..c5e97957 100644 --- a/SRC/slasv2.f +++ b/SRC/slasv2.f @@ -1,6 +1,6 @@ SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slaswp.f b/SRC/slaswp.f index 8b79fb72..50a94104 100644 --- a/SRC/slaswp.f +++ b/SRC/slaswp.f @@ -1,6 +1,6 @@ SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasy2.f b/SRC/slasy2.f index fb88a081..25ff25f7 100644 --- a/SRC/slasy2.f +++ b/SRC/slasy2.f @@ -1,7 +1,7 @@ SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slasyf.f b/SRC/slasyf.f index 545d2a32..1fcfcf71 100644 --- a/SRC/slasyf.f +++ b/SRC/slasyf.f @@ -1,6 +1,6 @@ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatbs.f b/SRC/slatbs.f index 04c425b3..a6a8fb73 100644 --- a/SRC/slatbs.f +++ b/SRC/slatbs.f @@ -1,7 +1,7 @@ SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatdf.f b/SRC/slatdf.f index 43156c7c..23cc6968 100644 --- a/SRC/slatdf.f +++ b/SRC/slatdf.f @@ -1,7 +1,7 @@ SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatps.f b/SRC/slatps.f index 278074d0..91ebb97c 100644 --- a/SRC/slatps.f +++ b/SRC/slatps.f @@ -1,7 +1,7 @@ SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatrd.f b/SRC/slatrd.f index befc85f9..e455151b 100644 --- a/SRC/slatrd.f +++ b/SRC/slatrd.f @@ -1,6 +1,6 @@ SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatrs.f b/SRC/slatrs.f index c065ae29..5b3f6894 100644 --- a/SRC/slatrs.f +++ b/SRC/slatrs.f @@ -1,7 +1,7 @@ SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatrz.f b/SRC/slatrz.f index 41f23830..2b8f8d8d 100644 --- a/SRC/slatrz.f +++ b/SRC/slatrz.f @@ -1,6 +1,6 @@ SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slatzm.f b/SRC/slatzm.f index d3f0f041..6b915da9 100644 --- a/SRC/slatzm.f +++ b/SRC/slatzm.f @@ -1,6 +1,6 @@ SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slauu2.f b/SRC/slauu2.f index 569c9464..323c0f50 100644 --- a/SRC/slauu2.f +++ b/SRC/slauu2.f @@ -1,6 +1,6 @@ SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slauum.f b/SRC/slauum.f index d3bf1eff..44dd2aaa 100644 --- a/SRC/slauum.f +++ b/SRC/slauum.f @@ -1,6 +1,6 @@ SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/slazq3.f b/SRC/slazq3.f deleted file mode 100644 index 8249a8ca..00000000 --- a/SRC/slazq3.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE SLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, - $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE - REAL DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX, - $ SIGMA, TAU -* .. -* .. Array Arguments .. - REAL Z( * ) -* .. -* -* Purpose -* ======= -* -* SLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds. -* In case of failure it changes shifts, and tries again until output -* is positive. -* -* Arguments -* ========= -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) REAL array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* DMIN (output) REAL -* Minimum value of d. -* -* SIGMA (output) REAL -* Sum of shifts used in current segment. -* -* DESIG (input/output) REAL -* Lower order part of SIGMA -* -* QMAX (input) REAL -* Maximum value of q. -* -* NFAIL (output) INTEGER -* Number of times shift was too big. -* -* ITER (output) INTEGER -* Number of iterations. -* -* NDIV (output) INTEGER -* Number of divisions. -* -* IEEE (input) LOGICAL -* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). -* -* TTYPE (input/output) INTEGER -* Shift type. TTYPE is passed as an argument in order to save -* its value between calls to SLAZQ3 -* -* DMIN1 (input/output) REAL -* DMIN2 (input/output) REAL -* DN (input/output) REAL -* DN1 (input/output) REAL -* DN2 (input/output) REAL -* TAU (input/output) REAL -* These are passed as arguments in order to save their values -* between calls to SLAZQ3 -* -* This is a thread safe version of SLASQ3, which passes TTYPE, DMIN1, -* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of -* declaring them in a SAVE statment. -* -* ===================================================================== -* -* .. Parameters .. - REAL CBIAS - PARAMETER ( CBIAS = 1.50E0 ) - REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD - PARAMETER ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0, - $ ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 ) -* .. -* .. Local Scalars .. - INTEGER IPN4, J4, N0IN, NN - REAL EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2 -* .. -* .. External Subroutines .. - EXTERNAL SLASQ5, SLASQ6, SLAZQ4 -* .. -* .. External Function .. - REAL SLAMCH - EXTERNAL SLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN, SQRT -* .. -* .. Executable Statements .. -* - N0IN = N0 - EPS = SLAMCH( 'Precision' ) - SAFMIN = SLAMCH( 'Safe minimum' ) - TOL = EPS*HUNDRD - TOL2 = TOL**2 - G = ZERO -* -* Check for deflation. -* - 10 CONTINUE -* - IF( N0.LT.I0 ) - $ RETURN - IF( N0.EQ.I0 ) - $ GO TO 20 - NN = 4*N0 + PP - IF( N0.EQ.( I0+1 ) ) - $ GO TO 40 -* -* Check whether E(N0-1) is negligible, 1 eigenvalue. -* - IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND. - $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) ) - $ GO TO 30 -* - 20 CONTINUE -* - Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA - N0 = N0 - 1 - GO TO 10 -* -* Check whether E(N0-2) is negligible, 2 eigenvalues. -* - 30 CONTINUE -* - IF( Z( NN-9 ).GT.TOL2*SIGMA .AND. - $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) ) - $ GO TO 50 -* - 40 CONTINUE -* - IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN - S = Z( NN-3 ) - Z( NN-3 ) = Z( NN-7 ) - Z( NN-7 ) = S - END IF - IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN - T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) ) - S = Z( NN-3 )*( Z( NN-5 ) / T ) - IF( S.LE.T ) THEN - S = Z( NN-3 )*( Z( NN-5 ) / - $ ( T*( ONE+SQRT( ONE+S / T ) ) ) ) - ELSE - S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) ) - END IF - T = Z( NN-7 ) + ( S+Z( NN-5 ) ) - Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T ) - Z( NN-7 ) = T - END IF - Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA - Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA - N0 = N0 - 2 - GO TO 10 -* - 50 CONTINUE -* -* Reverse the qd-array, if warranted. -* - IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN - IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN - IPN4 = 4*( I0+N0 ) - DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4 - TEMP = Z( J4-3 ) - Z( J4-3 ) = Z( IPN4-J4-3 ) - Z( IPN4-J4-3 ) = TEMP - TEMP = Z( J4-2 ) - Z( J4-2 ) = Z( IPN4-J4-2 ) - Z( IPN4-J4-2 ) = TEMP - TEMP = Z( J4-1 ) - Z( J4-1 ) = Z( IPN4-J4-5 ) - Z( IPN4-J4-5 ) = TEMP - TEMP = Z( J4 ) - Z( J4 ) = Z( IPN4-J4-4 ) - Z( IPN4-J4-4 ) = TEMP - 60 CONTINUE - IF( N0-I0.LE.4 ) THEN - Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 ) - Z( 4*N0-PP ) = Z( 4*I0-PP ) - END IF - DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) ) - Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ), - $ Z( 4*I0+PP+3 ) ) - Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ), - $ Z( 4*I0-PP+4 ) ) - QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) ) - DMIN = -ZERO - END IF - END IF -* - IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ), - $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN -* -* Choose a shift. -* - CALL SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1, - $ DN2, TAU, TTYPE, G ) -* -* Call dqds until DMIN > 0. -* - 80 CONTINUE -* - CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, IEEE ) -* - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 -* -* Check status. -* - IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN -* -* Success. -* - GO TO 100 -* - ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND. - $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND. - $ ABS( DN ).LT.TOL*SIGMA ) THEN -* -* Convergence hidden by negative DN. -* - Z( 4*( N0-1 )-PP+2 ) = ZERO - DMIN = ZERO - GO TO 100 - ELSE IF( DMIN.LT.ZERO ) THEN -* -* TAU too big. Select new TAU and try again. -* - NFAIL = NFAIL + 1 - IF( TTYPE.LT.-22 ) THEN -* -* Failed twice. Play it safe. -* - TAU = ZERO - ELSE IF( DMIN1.GT.ZERO ) THEN -* -* Late failure. Gives excellent shift. -* - TAU = ( TAU+DMIN )*( ONE-TWO*EPS ) - TTYPE = TTYPE - 11 - ELSE -* -* Early failure. Divide by 4. -* - TAU = QURTR*TAU - TTYPE = TTYPE - 12 - END IF - GO TO 80 - ELSE IF( DMIN.NE.DMIN ) THEN -* -* NaN. -* - TAU = ZERO - GO TO 80 - ELSE -* -* Possible underflow. Play it safe. -* - GO TO 90 - END IF - END IF -* -* Risk of underflow. -* - 90 CONTINUE - CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 ) - NDIV = NDIV + ( N0-I0+2 ) - ITER = ITER + 1 - TAU = ZERO -* - 100 CONTINUE - IF( TAU.LT.SIGMA ) THEN - DESIG = DESIG + TAU - T = SIGMA + DESIG - DESIG = DESIG - ( T-SIGMA ) - ELSE - T = SIGMA + TAU - DESIG = SIGMA - ( T-TAU ) + DESIG - END IF - SIGMA = T -* - RETURN -* -* End of SLAZQ3 -* - END diff --git a/SRC/slazq4.f b/SRC/slazq4.f deleted file mode 100644 index 54c362c0..00000000 --- a/SRC/slazq4.f +++ /dev/null @@ -1,330 +0,0 @@ - SUBROUTINE SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, - $ DN1, DN2, TAU, TTYPE, G ) -* -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* November 2006 -* -* .. Scalar Arguments .. - INTEGER I0, N0, N0IN, PP, TTYPE - REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU -* .. -* .. Array Arguments .. - REAL Z( * ) -* .. -* -* Purpose -* ======= -* -* SLAZQ4 computes an approximation TAU to the smallest eigenvalue -* using values of d from the previous transform. -* -* I0 (input) INTEGER -* First index. -* -* N0 (input) INTEGER -* Last index. -* -* Z (input) REAL array, dimension ( 4*N ) -* Z holds the qd array. -* -* PP (input) INTEGER -* PP=0 for ping, PP=1 for pong. -* -* N0IN (input) INTEGER -* The value of N0 at start of EIGTEST. -* -* DMIN (input) REAL -* Minimum value of d. -* -* DMIN1 (input) REAL -* Minimum value of d, excluding D( N0 ). -* -* DMIN2 (input) REAL -* Minimum value of d, excluding D( N0 ) and D( N0-1 ). -* -* DN (input) REAL -* d(N) -* -* DN1 (input) REAL -* d(N-1) -* -* DN2 (input) REAL -* d(N-2) -* -* TAU (output) REAL -* This is the shift. -* -* TTYPE (output) INTEGER -* Shift type. -* -* G (input/output) REAL -* G is passed as an argument in order to save its value between -* calls to SLAZQ4 -* -* Further Details -* =============== -* CNST1 = 9/16 -* -* This is a thread safe version of SLASQ4, which passes G through the -* argument list in place of declaring G in a SAVE statment. -* -* ===================================================================== -* -* .. Parameters .. - REAL CNST1, CNST2, CNST3 - PARAMETER ( CNST1 = 0.5630E0, CNST2 = 1.010E0, - $ CNST3 = 1.050E0 ) - REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD - PARAMETER ( QURTR = 0.250E0, THIRD = 0.3330E0, - $ HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0, - $ TWO = 2.0E0, HUNDRD = 100.0E0 ) -* .. -* .. Local Scalars .. - INTEGER I4, NN, NP - REAL A2, B1, B2, GAM, GAP1, GAP2, S -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* -* A negative DMIN forces the shift to take that absolute value -* TTYPE records the type of shift. -* - IF( DMIN.LE.ZERO ) THEN - TAU = -DMIN - TTYPE = -1 - RETURN - END IF -* - NN = 4*N0 + PP - IF( N0IN.EQ.N0 ) THEN -* -* No eigenvalues deflated. -* - IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN -* - B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) ) - B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) ) - A2 = Z( NN-7 ) + Z( NN-5 ) -* -* Cases 2 and 3. -* - IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN - GAP2 = DMIN2 - A2 - DMIN2*QURTR - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN - GAP1 = A2 - DN - ( B2 / GAP2 )*B2 - ELSE - GAP1 = A2 - DN - ( B1+B2 ) - END IF - IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN - S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN ) - TTYPE = -2 - ELSE - S = ZERO - IF( DN.GT.B1 ) - $ S = DN - B1 - IF( A2.GT.( B1+B2 ) ) - $ S = MIN( S, A2-( B1+B2 ) ) - S = MAX( S, THIRD*DMIN ) - TTYPE = -3 - END IF - ELSE -* -* Case 4. -* - TTYPE = -4 - S = QURTR*DMIN - IF( DMIN.EQ.DN ) THEN - GAM = DN - A2 = ZERO - IF( Z( NN-5 ) .GT. Z( NN-7 ) ) - $ RETURN - B2 = Z( NN-5 ) / Z( NN-7 ) - NP = NN - 9 - ELSE - NP = NN - 2*PP - B2 = Z( NP-2 ) - GAM = DN1 - IF( Z( NP-4 ) .GT. Z( NP-2 ) ) - $ RETURN - A2 = Z( NP-4 ) / Z( NP-2 ) - IF( Z( NN-9 ) .GT. Z( NN-11 ) ) - $ RETURN - B2 = Z( NN-9 ) / Z( NN-11 ) - NP = NN - 13 - END IF -* -* Approximate contribution to norm squared from I < NN-1. -* - A2 = A2 + B2 - DO 10 I4 = NP, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 20 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 20 - 10 CONTINUE - 20 CONTINUE - A2 = CNST3*A2 -* -* Rayleigh quotient residual bound. -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - END IF - ELSE IF( DMIN.EQ.DN2 ) THEN -* -* Case 5. -* - TTYPE = -5 - S = QURTR*DMIN -* -* Compute contribution to norm squared from I > NN-2. -* - NP = NN - 2*PP - B1 = Z( NP-2 ) - B2 = Z( NP-6 ) - GAM = DN2 - IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 ) - $ RETURN - A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 ) -* -* Approximate contribution to norm squared from I < NN-2. -* - IF( N0-I0.GT.2 ) THEN - B2 = Z( NN-13 ) / Z( NN-15 ) - A2 = A2 + B2 - DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4 - IF( B2.EQ.ZERO ) - $ GO TO 40 - B1 = B2 - IF( Z( I4 ) .GT. Z( I4-2 ) ) - $ RETURN - B2 = B2*( Z( I4 ) / Z( I4-2 ) ) - A2 = A2 + B2 - IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - A2 = CNST3*A2 - END IF -* - IF( A2.LT.CNST1 ) - $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 ) - ELSE -* -* Case 6, no information to guide us. -* - IF( TTYPE.EQ.-6 ) THEN - G = G + THIRD*( ONE-G ) - ELSE IF( TTYPE.EQ.-18 ) THEN - G = QURTR*THIRD - ELSE - G = QURTR - END IF - S = G*DMIN - TTYPE = -6 - END IF -* - ELSE IF( N0IN.EQ.( N0+1 ) ) THEN -* -* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. -* - IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN -* -* Cases 7 and 8. -* - TTYPE = -7 - S = THIRD*DMIN1 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 60 - DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - A2 = B1 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*MAX( B1, A2 ).LT.B2 ) - $ GO TO 60 - 50 CONTINUE - 60 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN1 / ( ONE+B2**2 ) - GAP2 = HALF*DMIN2 - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - TTYPE = -8 - END IF - ELSE -* -* Case 9. -* - S = QURTR*DMIN1 - IF( DMIN1.EQ.DN1 ) - $ S = HALF*DMIN1 - TTYPE = -9 - END IF -* - ELSE IF( N0IN.EQ.( N0+2 ) ) THEN -* -* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. -* -* Cases 10 and 11. -* - IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN - TTYPE = -10 - S = THIRD*DMIN2 - IF( Z( NN-5 ).GT.Z( NN-7 ) ) - $ RETURN - B1 = Z( NN-5 ) / Z( NN-7 ) - B2 = B1 - IF( B2.EQ.ZERO ) - $ GO TO 80 - DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4 - IF( Z( I4 ).GT.Z( I4-2 ) ) - $ RETURN - B1 = B1*( Z( I4 ) / Z( I4-2 ) ) - B2 = B2 + B1 - IF( HUNDRD*B1.LT.B2 ) - $ GO TO 80 - 70 CONTINUE - 80 CONTINUE - B2 = SQRT( CNST3*B2 ) - A2 = DMIN2 / ( ONE+B2**2 ) - GAP2 = Z( NN-7 ) + Z( NN-9 ) - - $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2 - IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN - S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) ) - ELSE - S = MAX( S, A2*( ONE-CNST2*B2 ) ) - END IF - ELSE - S = QURTR*DMIN2 - TTYPE = -11 - END IF - ELSE IF( N0IN.GT.( N0+2 ) ) THEN -* -* Case 12, more than two eigenvalues deflated. No information. -* - S = ZERO - TTYPE = -12 - END IF -* - TAU = S - RETURN -* -* End of SLAZQ4 -* - END diff --git a/SRC/sopgtr.f b/SRC/sopgtr.f index b459808f..9d1ad9e3 100644 --- a/SRC/sopgtr.f +++ b/SRC/sopgtr.f @@ -1,6 +1,6 @@ SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sopmtr.f b/SRC/sopmtr.f index f6779dc3..6ef5d99c 100644 --- a/SRC/sopmtr.f +++ b/SRC/sopmtr.f @@ -1,7 +1,7 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorg2l.f b/SRC/sorg2l.f index e277ffba..8879195b 100644 --- a/SRC/sorg2l.f +++ b/SRC/sorg2l.f @@ -1,6 +1,6 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorg2r.f b/SRC/sorg2r.f index dcb12462..89aaa615 100644 --- a/SRC/sorg2r.f +++ b/SRC/sorg2r.f @@ -1,6 +1,6 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgbr.f b/SRC/sorgbr.f index 3dd3afc6..5da0f795 100644 --- a/SRC/sorgbr.f +++ b/SRC/sorgbr.f @@ -1,6 +1,6 @@ SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorghr.f b/SRC/sorghr.f index 9f06120f..7cdbe457 100644 --- a/SRC/sorghr.f +++ b/SRC/sorghr.f @@ -1,6 +1,6 @@ SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgl2.f b/SRC/sorgl2.f index 5727f0ca..89236986 100644 --- a/SRC/sorgl2.f +++ b/SRC/sorgl2.f @@ -1,6 +1,6 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorglq.f b/SRC/sorglq.f index 0977a3f0..49e7e8ce 100644 --- a/SRC/sorglq.f +++ b/SRC/sorglq.f @@ -1,6 +1,6 @@ SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgql.f b/SRC/sorgql.f index ea33ba77..2667a5e9 100644 --- a/SRC/sorgql.f +++ b/SRC/sorgql.f @@ -1,6 +1,6 @@ SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgqr.f b/SRC/sorgqr.f index 1cc1b531..c550e834 100644 --- a/SRC/sorgqr.f +++ b/SRC/sorgqr.f @@ -1,6 +1,6 @@ SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgr2.f b/SRC/sorgr2.f index bf93b4fe..acc87d36 100644 --- a/SRC/sorgr2.f +++ b/SRC/sorgr2.f @@ -1,6 +1,6 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgrq.f b/SRC/sorgrq.f index 1278d8d9..dde6a094 100644 --- a/SRC/sorgrq.f +++ b/SRC/sorgrq.f @@ -1,6 +1,6 @@ SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorgtr.f b/SRC/sorgtr.f index 52a43be0..37848840 100644 --- a/SRC/sorgtr.f +++ b/SRC/sorgtr.f @@ -1,6 +1,6 @@ SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorm2l.f b/SRC/sorm2l.f index b90743f8..8ad9978a 100644 --- a/SRC/sorm2l.f +++ b/SRC/sorm2l.f @@ -1,7 +1,7 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorm2r.f b/SRC/sorm2r.f index be0947cf..ff248b3f 100644 --- a/SRC/sorm2r.f +++ b/SRC/sorm2r.f @@ -1,7 +1,7 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormbr.f b/SRC/sormbr.f index 2a0052a7..ba72abf4 100644 --- a/SRC/sormbr.f +++ b/SRC/sormbr.f @@ -1,7 +1,7 @@ SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormhr.f b/SRC/sormhr.f index 7d08286a..89a0c835 100644 --- a/SRC/sormhr.f +++ b/SRC/sormhr.f @@ -1,7 +1,7 @@ SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sorml2.f b/SRC/sorml2.f index 3ec71cbb..34d0327f 100644 --- a/SRC/sorml2.f +++ b/SRC/sorml2.f @@ -1,7 +1,7 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormlq.f b/SRC/sormlq.f index b8457b3b..c09779a6 100644 --- a/SRC/sormlq.f +++ b/SRC/sormlq.f @@ -1,7 +1,7 @@ SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormql.f b/SRC/sormql.f index 48b884df..e87798a4 100644 --- a/SRC/sormql.f +++ b/SRC/sormql.f @@ -1,7 +1,7 @@ SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormqr.f b/SRC/sormqr.f index a5df0ce0..c9270691 100644 --- a/SRC/sormqr.f +++ b/SRC/sormqr.f @@ -1,7 +1,7 @@ SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormr2.f b/SRC/sormr2.f index ea894e41..4c42aadf 100644 --- a/SRC/sormr2.f +++ b/SRC/sormr2.f @@ -1,7 +1,7 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormr3.f b/SRC/sormr3.f index fd1cfbf0..a0d0c578 100644 --- a/SRC/sormr3.f +++ b/SRC/sormr3.f @@ -1,7 +1,7 @@ SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormrq.f b/SRC/sormrq.f index 9ba2a0b7..744dd290 100644 --- a/SRC/sormrq.f +++ b/SRC/sormrq.f @@ -1,7 +1,7 @@ SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sormrz.f b/SRC/sormrz.f index 4a29bedd..60d788a6 100644 --- a/SRC/sormrz.f +++ b/SRC/sormrz.f @@ -1,7 +1,7 @@ SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/sormtr.f b/SRC/sormtr.f index 737914ab..f9ee68ae 100644 --- a/SRC/sormtr.f +++ b/SRC/sormtr.f @@ -1,7 +1,7 @@ SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbcon.f b/SRC/spbcon.f index be1de06a..db45a467 100644 --- a/SRC/spbcon.f +++ b/SRC/spbcon.f @@ -1,7 +1,7 @@ SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbequ.f b/SRC/spbequ.f index fe8101df..9d828268 100644 --- a/SRC/spbequ.f +++ b/SRC/spbequ.f @@ -1,6 +1,6 @@ SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbrfs.f b/SRC/spbrfs.f index 145a9149..e5840bd0 100644 --- a/SRC/spbrfs.f +++ b/SRC/spbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbstf.f b/SRC/spbstf.f index 8bd6936b..f3492e08 100644 --- a/SRC/spbstf.f +++ b/SRC/spbstf.f @@ -1,6 +1,6 @@ SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbsv.f b/SRC/spbsv.f index 58d977e2..3094e88c 100644 --- a/SRC/spbsv.f +++ b/SRC/spbsv.f @@ -1,6 +1,6 @@ SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbsvx.f b/SRC/spbsvx.f index 22d4927d..d0295c14 100644 --- a/SRC/spbsvx.f +++ b/SRC/spbsvx.f @@ -2,7 +2,7 @@ $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbtf2.f b/SRC/spbtf2.f index a5c223c3..3ff3703d 100644 --- a/SRC/spbtf2.f +++ b/SRC/spbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbtrf.f b/SRC/spbtrf.f index a50f6632..90cb0aac 100644 --- a/SRC/spbtrf.f +++ b/SRC/spbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spbtrs.f b/SRC/spbtrs.f index 22384772..f1de80eb 100644 --- a/SRC/spbtrs.f +++ b/SRC/spbtrs.f @@ -1,6 +1,6 @@ SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spftrf.f b/SRC/spftrf.f new file mode 100644 index 00000000..54083656 --- /dev/null +++ b/SRC/spftrf.f @@ -0,0 +1,397 @@ + SUBROUTINE SPFTRF( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER N, INFO +* .. +* .. Array Arguments .. + REAL A( 0: * ) +* +* Purpose +* ======= +* +* SPFTRF computes the Cholesky factorization of a real symmetric +* positive definite matrix A. +* +* The factorization has the form +* A = U**T * U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular. +* +* This is the block version of the algorithm, calling Level 3 BLAS. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) REAL array, dimension ( N*(N+1)/2 ); +* On entry, the symmetric matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +* the transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the NT elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization RFP A = U**T*U or RFP A = L*L**T. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i is not +* positive definite, and the factorization could not be +* completed. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYRK, SPOTRF, STRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SPFTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL SPOTRF( 'L', N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'R', 'L', 'T', 'N', N2, N1, ONE, A( 0 ), N, + + A( N1 ), N ) + CALL SSYRK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE, + + A( N ), N ) + CALL SPOTRF( 'U', N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL SPOTRF( 'L', N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'L', 'L', 'N', 'N', N1, N2, ONE, A( N2 ), N, + + A( 0 ), N ) + CALL SSYRK( 'U', 'T', N2, N1, -ONE, A( 0 ), N, ONE, + + A( N1 ), N ) + CALL SPOTRF( 'U', N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + CALL SPOTRF( 'U', N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'L', 'U', 'T', 'N', N1, N2, ONE, A( 0 ), N1, + + A( N1*N1 ), N1 ) + CALL SSYRK( 'L', 'T', N2, N1, -ONE, A( N1*N1 ), N1, ONE, + + A( 1 ), N1 ) + CALL SPOTRF( 'L', N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + CALL SPOTRF( 'U', N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'R', 'U', 'N', 'N', N2, N1, ONE, A( N2*N2 ), + + N2, A( 0 ), N2 ) + CALL SSYRK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE, + + A( N1*N2 ), N2 ) + CALL SPOTRF( 'L', N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL SPOTRF( 'L', K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'R', 'L', 'T', 'N', K, K, ONE, A( 1 ), N+1, + + A( K+1 ), N+1 ) + CALL SSYRK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE, + + A( 0 ), N+1 ) + CALL SPOTRF( 'U', K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL SPOTRF( 'L', K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'L', 'L', 'N', 'N', K, K, ONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL SSYRK( 'U', 'T', K, K, -ONE, A( 0 ), N+1, ONE, + + A( K ), N+1 ) + CALL SPOTRF( 'U', K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL SPOTRF( 'U', K, A( 0+K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'L', 'U', 'T', 'N', K, K, ONE, A( K ), N1, + + A( K*( K+1 ) ), K ) + CALL SSYRK( 'L', 'T', K, K, -ONE, A( K*( K+1 ) ), K, ONE, + + A( 0 ), K ) + CALL SPOTRF( 'L', K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL SPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRSM( 'R', 'U', 'N', 'N', K, K, ONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL SSYRK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE, + + A( K*K ), K ) + CALL SPOTRF( 'L', K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of SPFTRF +* + END diff --git a/SRC/spftri.f b/SRC/spftri.f new file mode 100644 index 00000000..a7dce352 --- /dev/null +++ b/SRC/spftri.f @@ -0,0 +1,362 @@ + SUBROUTINE SPFTRI( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. Array Arguments .. + REAL A( 0: * ) +* .. +* +* Purpose +* ======= +* +* SPFTRI computes the inverse of a real (symmetric) positive definite +* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T +* computed by SPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) REAL array, dimension ( N*(N+1)/2 ) +* On entry, the symmetric matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +* the transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'T'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, the symmetric inverse of the original matrix, in the +* same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the (i,i) element of the factor U or L is +* zero, and the inverse could not be computed. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, STFTRI, SLAUUM, STRMM, SSYRK +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SPFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL STFTRI( TRANSR, UPLO, 'N', N, A, INFO ) + IF( INFO.GT.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or +* inv(L)^C*inv(L). There are eight cases. +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) +* T1 -> a(0), T2 -> a(n), S -> a(N1) +* + CALL SLAUUM( 'L', N1, A( 0 ), N, INFO ) + CALL SSYRK( 'L', 'T', N1, N2, ONE, A( N1 ), N, ONE, + + A( 0 ), N ) + CALL STRMM( 'L', 'U', 'N', 'N', N2, N1, ONE, A( N ), N, + + A( N1 ), N ) + CALL SLAUUM( 'U', N2, A( N ), N, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) +* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) +* T1 -> a(N2), T2 -> a(N1), S -> a(0) +* + CALL SLAUUM( 'L', N1, A( N2 ), N, INFO ) + CALL SSYRK( 'L', 'N', N1, N2, ONE, A( 0 ), N, ONE, + + A( N2 ), N ) + CALL STRMM( 'R', 'U', 'T', 'N', N1, N2, ONE, A( N1 ), N, + + A( 0 ), N ) + CALL SLAUUM( 'U', N2, A( N1 ), N, INFO ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) +* + CALL SLAUUM( 'U', N1, A( 0 ), N1, INFO ) + CALL SSYRK( 'U', 'N', N1, N2, ONE, A( N1*N1 ), N1, ONE, + + A( 0 ), N1 ) + CALL STRMM( 'R', 'L', 'N', 'N', N1, N2, ONE, A( 1 ), N1, + + A( N1*N1 ), N1 ) + CALL SLAUUM( 'L', N2, A( 1 ), N1, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is odd +* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) +* + CALL SLAUUM( 'U', N1, A( N2*N2 ), N2, INFO ) + CALL SSYRK( 'U', 'T', N1, N2, ONE, A( 0 ), N2, ONE, + + A( N2*N2 ), N2 ) + CALL STRMM( 'L', 'L', 'T', 'N', N2, N1, ONE, A( N1*N2 ), + + N2, A( 0 ), N2 ) + CALL SLAUUM( 'L', N2, A( N1*N2 ), N2, INFO ) +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL SLAUUM( 'L', K, A( 1 ), N+1, INFO ) + CALL SSYRK( 'L', 'T', K, K, ONE, A( K+1 ), N+1, ONE, + + A( 1 ), N+1 ) + CALL STRMM( 'L', 'U', 'N', 'N', K, K, ONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) + CALL SLAUUM( 'U', K, A( 0 ), N+1, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL SLAUUM( 'L', K, A( K+1 ), N+1, INFO ) + CALL SSYRK( 'L', 'N', K, K, ONE, A( 0 ), N+1, ONE, + + A( K+1 ), N+1 ) + CALL STRMM( 'R', 'U', 'T', 'N', K, K, ONE, A( K ), N+1, + + A( 0 ), N+1 ) + CALL SLAUUM( 'U', K, A( K ), N+1, INFO ) +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL SLAUUM( 'U', K, A( K ), K, INFO ) + CALL SSYRK( 'U', 'N', K, K, ONE, A( K*( K+1 ) ), K, ONE, + + A( K ), K ) + CALL STRMM( 'R', 'L', 'N', 'N', K, K, ONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + CALL SLAUUM( 'L', K, A( 0 ), K, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL SLAUUM( 'U', K, A( K*( K+1 ) ), K, INFO ) + CALL SSYRK( 'U', 'T', K, K, ONE, A( 0 ), K, ONE, + + A( K*( K+1 ) ), K ) + CALL STRMM( 'L', 'L', 'T', 'N', K, K, ONE, A( K*K ), K, + + A( 0 ), K ) + CALL SLAUUM( 'L', K, A( K*K ), K, INFO ) +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of SPFTRI +* + END diff --git a/SRC/spftrs.f b/SRC/spftrs.f new file mode 100644 index 00000000..5bde02ec --- /dev/null +++ b/SRC/spftrs.f @@ -0,0 +1,209 @@ + SUBROUTINE SPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + REAL A( 0: * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* SPFTRS solves a system of linear equations A*X = B with a symmetric +* positive definite matrix A using the Cholesky factorization +* A = U**T*U or A = L*L**T computed by SPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) REAL array, dimension ( N*(N+1)/2 ) +* The triangular factor U or L from the Cholesky factorization +* of RFP A = U**H*U or RFP A = L*L**T, as computed by SPFTRF. +* See note below for more details about RFP A. +* +* B (input/output) REAL array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, STFSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SPFTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + + RETURN +* +* start execution: there are two triangular solves +* + IF( LOWER ) THEN + CALL STFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, + + LDB ) + CALL STFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, + + LDB ) + ELSE + CALL STFSM( TRANSR, 'L', UPLO, 'T', 'N', N, NRHS, ONE, A, B, + + LDB ) + CALL STFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, ONE, A, B, + + LDB ) + END IF +* + RETURN +* +* End of SPFTRS +* + END diff --git a/SRC/spocon.f b/SRC/spocon.f index dacba229..c5aaec39 100644 --- a/SRC/spocon.f +++ b/SRC/spocon.f @@ -1,7 +1,7 @@ SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spoequ.f b/SRC/spoequ.f index 6ee0fc0c..f5410aac 100644 --- a/SRC/spoequ.f +++ b/SRC/spoequ.f @@ -1,6 +1,6 @@ SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spoequb.f b/SRC/spoequb.f new file mode 100644 index 00000000..13b13191 --- /dev/null +++ b/SRC/spoequb.f @@ -0,0 +1,152 @@ + SUBROUTINE SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + REAL AMAX, SCOND +* .. +* .. Array Arguments .. + REAL A( LDA, * ), S( * ) +* .. +* +* Purpose +* ======= +* +* SPOEQU computes row and column scalings intended to equilibrate a +* symmetric positive definite matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The N-by-N symmetric positive definite matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) REAL array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) REAL +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I + REAL SMIN, BASE, TMP +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, LOG, INT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* +* Positive definite only performs 1 pass of equilibration. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SPOEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF + + BASE = SLAMCH( 'B' ) + TMP = -0.5 / LOG ( BASE ) +* +* Find the minimum and maximum diagonal elements. +* + S( 1 ) = A( 1, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) + DO 10 I = 2, N + S( I ) = A( I, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = BASE ** INT( TMP * LOG( S( I ) ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)). +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF +* + RETURN +* +* End of SPOEQUB +* + END diff --git a/SRC/sporfs.f b/SRC/sporfs.f index 5b3577f4..4b8630d3 100644 --- a/SRC/sporfs.f +++ b/SRC/sporfs.f @@ -1,7 +1,7 @@ SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sporfsx.f b/SRC/sporfsx.f new file mode 100644 index 00000000..0b5cb181 --- /dev/null +++ b/SRC/sporfsx.f @@ -0,0 +1,568 @@ + SUBROUTINE SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, + $ LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SPORFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric positive +* definite, and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular part +* of the matrix A, and the strictly lower triangular part of A +* is not referenced. If UPLO = 'L', the leading N-by-N lower +* triangular part of A contains the lower triangular part of +* the matrix A, and the strictly upper triangular part of A is +* not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) REAL array, dimension (LDAF,N) +* The triangular factor U or L from the Cholesky factorization +* A = U**T*U or A = L*L**T, as computed by SPOTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* S (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) REAL array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) REAL array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SPOCON, SLA_PORFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, SLANSY, SLA_PORCOND + REAL SLAMCH, SLANSY, SLA_PORCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N ) * SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME(UPLO, 'U') .AND. .NOT.LSAME(UPLO, 'L')) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SPORFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = SLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL SPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + CALL SLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), WORK( 1 ), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) ) * SLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ -1, S, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, + $ 0, S, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF (N_ERR_BNDS .GE. LA_LINRX_RCOND_I) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = SLA_PORCOND( UPLO, N, A, LDA, AF, LDAF, 1, + $ X( 1, J ), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of SPORFSX +* + END diff --git a/SRC/sposv.f b/SRC/sposv.f index 8247741e..0e030990 100644 --- a/SRC/sposv.f +++ b/SRC/sposv.f @@ -1,6 +1,6 @@ SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sposvx.f b/SRC/sposvx.f index 9fb1e0bc..e916916a 100644 --- a/SRC/sposvx.f +++ b/SRC/sposvx.f @@ -2,7 +2,7 @@ $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sposvxx.f b/SRC/sposvxx.f new file mode 100644 index 00000000..21b1c20e --- /dev/null +++ b/SRC/sposvxx.f @@ -0,0 +1,554 @@ + SUBROUTINE SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, + $ S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T +* to compute the solution to a real system of linear equations +* A * X = B, where A is an N-by-N symmetric positive definite matrix +* and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. SPOSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* SPOSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* SPOSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what SPOSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +* factor the matrix A (after equilibration if FACT = 'E') as +* A = U**T* U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is a lower triangular +* matrix. +* +* 3. If the leading i-by-i principal minor is not positive definite, +* then the routine returns with INFO = i. Otherwise, the factored +* form of A is used to estimate the condition number of the matrix +* A (see argument RCOND). If the reciprocal of the condition number +* is less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(S) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF contains the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A and AF are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = +* 'Y', then A must contain the equilibrated matrix +* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper +* triangular part of A contains the upper triangular part of the +* matrix A, and the strictly lower triangular part of A is not +* referenced. If UPLO = 'L', the leading N-by-N lower triangular +* part of A contains the lower triangular part of the matrix A, and +* the strictly upper triangular part of A is not referenced. A is +* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = +* 'N' on exit. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) REAL array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T, in the same storage +* format as A. If EQUED .ne. 'N', then AF is the factored +* form of the equilibrated matrix diag(S)*A*diag(S). +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the original +* matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the equilibrated +* matrix A (see the description of A for the form of the +* equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) REAL array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) REAL array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) REAL array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, SMIN, SMAX, + $ SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, SLA_PORPVGRW + LOGICAL LSAME + REAL SLAMCH, SLA_PORPVGRW +* .. +* .. External Subroutines .. + EXTERNAL SPOEQUB, SPOTRF, SPOTRS, SLACPY, SLAQSY, + $ XERBLA, SLASCL2, SPORFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in SPORFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until SPORFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SPOSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL SPOEQUB( N, A, LDA, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL SLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL SPOTRF( UPLO, N, AF, LDAF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.NE.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = SLA_PORPVGRW( UPLO, INFO, A, LDA, AF, LDAF, WORK ) + RETURN + ENDIF + END IF +* +* Compute the reciprocal growth factor RPVGRW. +* + RPVGRW = SLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) +* +* Compute the solution matrix X. +* + CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL SPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL SPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO ) + +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL SLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of SPOSVXX +* + END diff --git a/SRC/spotf2.f b/SRC/spotf2.f index 247ccb0e..da48261b 100644 --- a/SRC/spotf2.f +++ b/SRC/spotf2.f @@ -1,6 +1,6 @@ SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -71,9 +71,9 @@ REAL AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, SISNAN REAL SDOT - EXTERNAL LSAME, SDOT + EXTERNAL LSAME, SDOT, SISNAN * .. * .. External Subroutines .. EXTERNAL SGEMV, SSCAL, XERBLA @@ -113,7 +113,7 @@ * Compute U(J,J) and test for non-positive-definiteness. * AJJ = A( J, J ) - SDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF @@ -138,7 +138,7 @@ * AJJ = A( J, J ) - SDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), $ LDA ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.SISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF diff --git a/SRC/spotrf.f b/SRC/spotrf.f index 396fdb07..6da443fa 100644 --- a/SRC/spotrf.f +++ b/SRC/spotrf.f @@ -1,6 +1,6 @@ SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spotri.f b/SRC/spotri.f index 75fefa22..ce217072 100644 --- a/SRC/spotri.f +++ b/SRC/spotri.f @@ -1,6 +1,6 @@ SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spotrs.f b/SRC/spotrs.f index 27d449ce..bcc99e6b 100644 --- a/SRC/spotrs.f +++ b/SRC/spotrs.f @@ -1,6 +1,6 @@ SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sppcon.f b/SRC/sppcon.f index baccb8ef..f9f55a1c 100644 --- a/SRC/sppcon.f +++ b/SRC/sppcon.f @@ -1,6 +1,6 @@ SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sppequ.f b/SRC/sppequ.f index 3f07ac0e..7b9c6190 100644 --- a/SRC/sppequ.f +++ b/SRC/sppequ.f @@ -1,6 +1,6 @@ SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spprfs.f b/SRC/spprfs.f index 16b066ce..6d59328c 100644 --- a/SRC/spprfs.f +++ b/SRC/spprfs.f @@ -1,7 +1,7 @@ SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sppsv.f b/SRC/sppsv.f index 22331705..04761648 100644 --- a/SRC/sppsv.f +++ b/SRC/sppsv.f @@ -1,6 +1,6 @@ SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sppsvx.f b/SRC/sppsvx.f index 1e8c257b..ba114c41 100644 --- a/SRC/sppsvx.f +++ b/SRC/sppsvx.f @@ -1,7 +1,7 @@ SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spptrf.f b/SRC/spptrf.f index cf5e3a21..5035df9f 100644 --- a/SRC/spptrf.f +++ b/SRC/spptrf.f @@ -1,6 +1,6 @@ SUBROUTINE SPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spptri.f b/SRC/spptri.f index 5cb06f26..7b5bd68b 100644 --- a/SRC/spptri.f +++ b/SRC/spptri.f @@ -1,6 +1,6 @@ SUBROUTINE SPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spptrs.f b/SRC/spptrs.f index c82b9de6..118410c6 100644 --- a/SRC/spptrs.f +++ b/SRC/spptrs.f @@ -1,6 +1,6 @@ SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spstf2.f b/SRC/spstf2.f new file mode 100644 index 00000000..df0530bf --- /dev/null +++ b/SRC/spstf2.f @@ -0,0 +1,308 @@ + SUBROUTINE SPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK PROTOTYPE routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* SPSTF2 computes the Cholesky factorization with complete +* pivoting of a real symmetric positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 2 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) REAL +* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK REAL array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + REAL AJJ, SSTOP, STEMP + INTEGER I, ITEMP, J, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME, SISNAN + EXTERNAL SLAMCH, LSAME, SISNAN +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SSCAL, SSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT, MAXLOC +* .. +* .. 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( 'SPSTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + PVT = 1 + AJJ = A( PVT, PVT ) + DO I = 2, N + IF( A( I, I ).GT.AJJ ) THEN + PVT = I + AJJ = A( PVT, PVT ) + END IF + END DO + IF( AJJ.EQ.ZERO.OR.SISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 170 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + SSTOP = N * SLAMCH( 'Epsilon' ) * AJJ + ELSE + SSTOP = TOL + END IF +* +* Set first half of WORK to zero, holds dot products +* + DO 110 I = 1, N + WORK( I ) = 0 + 110 CONTINUE +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 130 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 120 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + A( J-1, I )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 120 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 160 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL SSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL SSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + CALL SSWAP( PVT-J-1, A( J, J+1 ), LDA, A( J+1, PVT ), 1 ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J +* + IF( J.LT.N ) THEN + CALL SGEMV( 'Trans', J-1, N-J, -ONE, A( 1, J+1 ), LDA, + $ A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) + CALL SSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 130 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 150 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 140 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + A( I, J-1 )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 140 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 160 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL SSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL SSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1, PVT ), + $ 1 ) + CALL SSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), LDA ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J +* + IF( J.LT.N ) THEN + CALL SGEMV( 'No Trans', N-J, J-1, -ONE, A( J+1, 1 ), LDA, + $ A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) + CALL SSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 150 CONTINUE +* + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 170 + 160 CONTINUE +* +* Rank is number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 170 CONTINUE + RETURN +* +* End of SPSTF2 +* + END diff --git a/SRC/spstrf.f b/SRC/spstrf.f new file mode 100644 index 00000000..92b04a89 --- /dev/null +++ b/SRC/spstrf.f @@ -0,0 +1,366 @@ + SUBROUTINE SPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A( LDA, * ), WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* SPSTRF computes the Cholesky factorization with complete +* pivoting of a real symmetric positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 3 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) REAL +* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK REAL array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + REAL AJJ, SSTOP, STEMP + INTEGER I, ITEMP, J, JB, K, NB, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + REAL SLAMCH + INTEGER ILAENV + LOGICAL LSAME, SISNAN + EXTERNAL SLAMCH, ILAENV, LSAME, SISNAN +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SPSTF2, SSCAL, SSWAP, SSYRK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, MAXLOC +* .. +* .. 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( 'SPSTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get block size +* + NB = ILAENV( 1, 'SPOTRF', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL SPSTF2( UPLO, N, A( 1, 1 ), LDA, PIV, RANK, TOL, WORK, + $ INFO ) + GO TO 200 +* + ELSE +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + PVT = 1 + AJJ = A( PVT, PVT ) + DO I = 2, N + IF( A( I, I ).GT.AJJ ) THEN + PVT = I + AJJ = A( PVT, PVT ) + END IF + END DO + IF( AJJ.EQ.ZERO.OR.SISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 200 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + SSTOP = N * SLAMCH( 'Epsilon' ) * AJJ + ELSE + SSTOP = TOL + END IF +* +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 140 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 110 I = K, N + WORK( I ) = 0 + 110 CONTINUE +* + DO 130 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 120 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + A( J-1, I )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 120 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL SSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL SSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + CALL SSWAP( PVT-J-1, A( J, J+1 ), LDA, + $ A( J+1, PVT ), 1 ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL SGEMV( 'Trans', J-K, N-J, -ONE, A( K, J+1 ), + $ LDA, A( K, J ), 1, ONE, A( J, J+1 ), + $ LDA ) + CALL SSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 130 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL SSYRK( 'Upper', 'Trans', N-J+1, JB, -ONE, + $ A( K, J ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 140 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 180 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 150 I = K, N + WORK( I ) = 0 + 150 CONTINUE +* + DO 170 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 160 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + A( I, J-1 )**2 + END IF + WORK( N+I ) = A( I, I ) - WORK( I ) +* + 160 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.SSTOP.OR.SISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL SSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL SSWAP( N-PVT, A( PVT+1, J ), 1, + $ A( PVT+1, PVT ), 1 ) + CALL SSWAP( PVT-J-1, A( J+1, J ), 1, A( PVT, J+1 ), + $ LDA ) +* +* Swap dot products and PIV +* + STEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = STEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL SGEMV( 'No Trans', N-J, J-K, -ONE, + $ A( J+1, K ), LDA, A( J, K ), LDA, ONE, + $ A( J+1, J ), 1 ) + CALL SSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 170 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL SSYRK( 'Lower', 'No Trans', N-J+1, JB, -ONE, + $ A( J, K ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 180 CONTINUE +* + END IF + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 200 + 190 CONTINUE +* +* Rank is the number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 200 CONTINUE + RETURN +* +* End of SPSTRF +* + END diff --git a/SRC/sptcon.f b/SRC/sptcon.f index 3144bde3..4314684e 100644 --- a/SRC/sptcon.f +++ b/SRC/sptcon.f @@ -1,6 +1,6 @@ SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spteqr.f b/SRC/spteqr.f index a9cd707b..8deeec39 100644 --- a/SRC/spteqr.f +++ b/SRC/spteqr.f @@ -1,6 +1,6 @@ SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sptrfs.f b/SRC/sptrfs.f index d7241dd5..f3554131 100644 --- a/SRC/sptrfs.f +++ b/SRC/sptrfs.f @@ -1,7 +1,7 @@ SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, $ BERR, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sptsv.f b/SRC/sptsv.f index 6c3c515a..7cea762e 100644 --- a/SRC/sptsv.f +++ b/SRC/sptsv.f @@ -1,6 +1,6 @@ SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sptsvx.f b/SRC/sptsvx.f index 9c7527b8..8f166db4 100644 --- a/SRC/sptsvx.f +++ b/SRC/sptsvx.f @@ -1,7 +1,7 @@ SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spttrf.f b/SRC/spttrf.f index cb3df359..c806495e 100644 --- a/SRC/spttrf.f +++ b/SRC/spttrf.f @@ -1,6 +1,6 @@ SUBROUTINE SPTTRF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/spttrs.f b/SRC/spttrs.f index 569e2330..0079d4df 100644 --- a/SRC/spttrs.f +++ b/SRC/spttrs.f @@ -1,6 +1,6 @@ SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sptts2.f b/SRC/sptts2.f index cf81cc3e..9701bff0 100644 --- a/SRC/sptts2.f +++ b/SRC/sptts2.f @@ -1,6 +1,6 @@ SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/srscl.f b/SRC/srscl.f index d40646a0..a293f4ab 100644 --- a/SRC/srscl.f +++ b/SRC/srscl.f @@ -1,6 +1,6 @@ SUBROUTINE SRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbev.f b/SRC/ssbev.f index 064b2dce..3c0c3c34 100644 --- a/SRC/ssbev.f +++ b/SRC/ssbev.f @@ -1,7 +1,7 @@ SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbevd.f b/SRC/ssbevd.f index 64fbc827..68254f0b 100644 --- a/SRC/ssbevd.f +++ b/SRC/ssbevd.f @@ -1,7 +1,7 @@ SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbevx.f b/SRC/ssbevx.f index 9aad3fae..237b5c37 100644 --- a/SRC/ssbevx.f +++ b/SRC/ssbevx.f @@ -2,7 +2,7 @@ $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbgst.f b/SRC/ssbgst.f index 89637a42..4851b2d8 100644 --- a/SRC/ssbgst.f +++ b/SRC/ssbgst.f @@ -1,7 +1,7 @@ SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbgv.f b/SRC/ssbgv.f index d89bb921..43e3b005 100644 --- a/SRC/ssbgv.f +++ b/SRC/ssbgv.f @@ -1,7 +1,7 @@ SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbgvd.f b/SRC/ssbgvd.f index 95f46e10..f1417b54 100644 --- a/SRC/ssbgvd.f +++ b/SRC/ssbgvd.f @@ -1,7 +1,7 @@ SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbgvx.f b/SRC/ssbgvx.f index e2baaac2..cdad14bb 100644 --- a/SRC/ssbgvx.f +++ b/SRC/ssbgvx.f @@ -2,7 +2,7 @@ $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssbtrd.f b/SRC/ssbtrd.f index 72fb9e17..5bbe8708 100644 --- a/SRC/ssbtrd.f +++ b/SRC/ssbtrd.f @@ -1,7 +1,7 @@ SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssfrk.f b/SRC/ssfrk.f new file mode 100644 index 00000000..a42ccbf1 --- /dev/null +++ b/SRC/ssfrk.f @@ -0,0 +1,470 @@ + SUBROUTINE SSFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, + + C ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + REAL ALPHA, BETA + INTEGER K, LDA, N + CHARACTER TRANS, TRANSR, UPLO +* .. +* .. Array Arguments .. + REAL A( LDA, * ), C( * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for C in RFP Format. +* +* SSFRK performs one of the symmetric rank--k operations +* +* C := alpha*A*A' + beta*C, +* +* or +* +* C := alpha*A'*A + beta*C, +* +* where alpha and beta are real scalars, C is an n--by--n symmetric +* matrix and A is an n--by--k matrix in the first case and a k--by--n +* matrix in the second case. +* +* Arguments +* ========== +* +* TRANSR (input) CHARACTER +* = 'N': The Normal Form of RFP A is stored; +* = 'T': The Transpose Form of RFP A is stored. +* +* UPLO - (input) CHARACTER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array C is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of C +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of C +* is to be referenced. +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. +* +* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. +* +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the order of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - (input) INTEGER. +* On entry with TRANS = 'N' or 'n', K specifies the number +* of columns of the matrix A, and on entry with TRANS = 'T' +* or 't', K specifies the number of rows of the matrix A. K +* must be at least zero. +* Unchanged on exit. +* +* ALPHA - (input) REAL. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - (input) REAL array of DIMENSION ( LDA, ka ), where KA +* is K when TRANS = 'N' or 'n', and is N otherwise. Before +* entry with TRANS = 'N' or 'n', the leading N--by--K part of +* the array A must contain the matrix A, otherwise the leading +* K--by--N part of the array A must contain the matrix A. +* Unchanged on exit. +* +* LDA - (input) INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDA must be at least max( 1, n ), otherwise LDA must +* be at least max( 1, k ). +* Unchanged on exit. +* +* BETA - (input) REAL. +* On entry, BETA specifies the scalar beta. +* Unchanged on exit. +* +* +* C - (input/output) REAL array, dimension ( NT ); +* NT = N*(N+1)/2. On entry, the symmetric matrix C in RFP +* Format. RFP Format is described by TRANSR, UPLO and N. +* +* Arguments +* ========== +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS + INTEGER INFO, NROWA, J, NK, N1, N2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, SSYRK, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) +* + IF( NOTRANS ) THEN + NROWA = N + ELSE + NROWA = K + END IF +* + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSFRK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* +* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not +* done (it is in SSYRK for example) and left in the general case. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + + ( BETA.EQ.ONE ) ) )RETURN +* + IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN + DO J = 1, ( ( N*( N+1 ) ) / 2 ) + C( J ) = ZERO + END DO + RETURN + END IF +* +* C is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and NK. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + NK = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL SSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL SSYRK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N+1 ), N ) + CALL SGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' +* + CALL SSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL SSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N+1 ), N ) + CALL SGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( N1+1 ), N ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL SSYRK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL SSYRK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, + + BETA, C( N1+1 ), N ) + CALL SGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( N2, 1 ), LDA, BETA, C( 1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' +* + CALL SSYRK( 'L', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL SSYRK( 'U', 'T', N2, K, ALPHA, A( 1, N2 ), LDA, + + BETA, C( N1+1 ), N ) + CALL SGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, N2 ), LDA, BETA, C( 1 ), N ) +* + END IF +* + END IF +* + ELSE +* +* N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' +* + CALL SSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL SSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL SGEMM( 'N', 'T', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( N1+1, 1 ), LDA, BETA, + + C( N1*N1+1 ), N1 ) +* + ELSE +* +* N is odd, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' +* + CALL SSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL SSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL SGEMM( 'T', 'N', N1, N2, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, N1+1 ), LDA, BETA, + + C( N1*N1+1 ), N1 ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' +* + CALL SSYRK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL SSYRK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL SGEMM( 'N', 'T', N2, N1, K, ALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) +* + ELSE +* +* N is odd, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' +* + CALL SSYRK( 'U', 'T', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL SSYRK( 'L', 'T', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL SGEMM( 'T', 'N', N2, N1, K, ALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), N2 ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'T' +* + CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( NK+2 ), + + N+1 ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, BETA, C( 1 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'T' +* + CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, BETA, C( 1 ), + + N+1 ) +* + END IF +* + END IF +* + ELSE +* +* N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'N' +* + CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), NK ) + CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, BETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'T', UPLO = 'L', and TRANS = 'T' +* + CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), NK ) + CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, BETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'N' +* + CALL SSYRK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL SSYRK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL SGEMM( 'N', 'T', NK, NK, K, ALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'T', UPLO = 'U', and TRANS = 'T' +* + CALL SSYRK( 'U', 'T', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL SSYRK( 'L', 'T', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL SGEMM( 'T', 'N', NK, NK, K, ALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, BETA, C( 1 ), NK ) +* + END IF +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of SSFRK +* + END diff --git a/SRC/sspcon.f b/SRC/sspcon.f index 12c77121..ddda639b 100644 --- a/SRC/sspcon.f +++ b/SRC/sspcon.f @@ -1,7 +1,7 @@ SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspev.f b/SRC/sspev.f index 21ea1dea..8f19fc77 100644 --- a/SRC/sspev.f +++ b/SRC/sspev.f @@ -1,6 +1,6 @@ SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspevd.f b/SRC/sspevd.f index b84319df..0d8ea132 100644 --- a/SRC/sspevd.f +++ b/SRC/sspevd.f @@ -1,7 +1,7 @@ SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspevx.f b/SRC/sspevx.f index 8419d7e5..6577200e 100644 --- a/SRC/sspevx.f +++ b/SRC/sspevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -329,7 +329,7 @@ * form to eigenvectors returned by SSTEIN. * CALL SOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), INFO ) + $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. diff --git a/SRC/sspgst.f b/SRC/sspgst.f index e78ce11e..8bca8000 100644 --- a/SRC/sspgst.f +++ b/SRC/sspgst.f @@ -1,6 +1,6 @@ SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspgv.f b/SRC/sspgv.f index 40840562..d7e75398 100644 --- a/SRC/sspgv.f +++ b/SRC/sspgv.f @@ -1,7 +1,7 @@ SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspgvd.f b/SRC/sspgvd.f index 7458de40..39e14298 100644 --- a/SRC/sspgvd.f +++ b/SRC/sspgvd.f @@ -1,7 +1,7 @@ SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspgvx.f b/SRC/sspgvx.f index e92d3bd9..33be97ba 100644 --- a/SRC/sspgvx.f +++ b/SRC/sspgvx.f @@ -2,7 +2,7 @@ $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssprfs.f b/SRC/ssprfs.f index 79528f47..6d6e8bae 100644 --- a/SRC/ssprfs.f +++ b/SRC/ssprfs.f @@ -1,7 +1,7 @@ SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspsv.f b/SRC/sspsv.f index a8737e19..956ecd40 100644 --- a/SRC/sspsv.f +++ b/SRC/sspsv.f @@ -1,6 +1,6 @@ SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sspsvx.f b/SRC/sspsvx.f index 69b2b025..69d3f77f 100644 --- a/SRC/sspsvx.f +++ b/SRC/sspsvx.f @@ -1,7 +1,7 @@ SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssptrd.f b/SRC/ssptrd.f index 68d3d459..649e61c3 100644 --- a/SRC/ssptrd.f +++ b/SRC/ssptrd.f @@ -1,6 +1,6 @@ SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssptrf.f b/SRC/ssptrf.f index 28c53c07..3f4b84de 100644 --- a/SRC/ssptrf.f +++ b/SRC/ssptrf.f @@ -1,6 +1,6 @@ SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssptri.f b/SRC/ssptri.f index 40aa1c80..99ea5fdf 100644 --- a/SRC/ssptri.f +++ b/SRC/ssptri.f @@ -1,6 +1,6 @@ SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssptrs.f b/SRC/ssptrs.f index 566163b2..da85425e 100644 --- a/SRC/ssptrs.f +++ b/SRC/ssptrs.f @@ -1,6 +1,6 @@ SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstebz.f b/SRC/sstebz.f index 306f24e1..a2180fdc 100644 --- a/SRC/sstebz.f +++ b/SRC/sstebz.f @@ -2,7 +2,7 @@ $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * 8-18-00: Increase FUDGE factor for T3E (eca) diff --git a/SRC/sstedc.f b/SRC/sstedc.f index 444e659a..e093e949 100644 --- a/SRC/sstedc.f +++ b/SRC/sstedc.f @@ -1,7 +1,7 @@ SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstegr.f b/SRC/sstegr.f index 583d2326..022dc071 100644 --- a/SRC/sstegr.f +++ b/SRC/sstegr.f @@ -5,7 +5,7 @@ IMPLICIT NONE * * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstein.f b/SRC/sstein.f index be2decc4..4460ef79 100644 --- a/SRC/sstein.f +++ b/SRC/sstein.f @@ -1,7 +1,7 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstemr.f b/SRC/sstemr.f index 832bfd11..9d209335 100644 --- a/SRC/sstemr.f +++ b/SRC/sstemr.f @@ -3,7 +3,7 @@ $ IWORK, LIWORK, INFO ) IMPLICIT NONE * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssteqr.f b/SRC/ssteqr.f index 15a2d356..26edf4d6 100644 --- a/SRC/ssteqr.f +++ b/SRC/ssteqr.f @@ -1,6 +1,6 @@ SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssterf.f b/SRC/ssterf.f index f56d56ef..5332578e 100644 --- a/SRC/ssterf.f +++ b/SRC/ssterf.f @@ -1,6 +1,6 @@ SUBROUTINE SSTERF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstev.f b/SRC/sstev.f index fabd6e77..f934c5d8 100644 --- a/SRC/sstev.f +++ b/SRC/sstev.f @@ -1,6 +1,6 @@ SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstevd.f b/SRC/sstevd.f index 045ec9d9..247a3973 100644 --- a/SRC/sstevd.f +++ b/SRC/sstevd.f @@ -1,7 +1,7 @@ SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstevr.f b/SRC/sstevr.f index 48c9ce22..50b88ba7 100644 --- a/SRC/sstevr.f +++ b/SRC/sstevr.f @@ -2,7 +2,7 @@ $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/sstevx.f b/SRC/sstevx.f index dd57159d..b760daa9 100644 --- a/SRC/sstevx.f +++ b/SRC/sstevx.f @@ -1,7 +1,7 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssycon.f b/SRC/ssycon.f index 8118549c..6264522b 100644 --- a/SRC/ssycon.f +++ b/SRC/ssycon.f @@ -1,7 +1,7 @@ SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssyequb.f b/SRC/ssyequb.f new file mode 100644 index 00000000..e50a5818 --- /dev/null +++ b/SRC/ssyequb.f @@ -0,0 +1,251 @@ + SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + REAL AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A( LDA, * ), S( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* SSYEQUB computes row and column scalings intended to equilibrate a +* symmetric matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The N-by-N symmetric matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) REAL array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) REAL +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) REAL +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + REAL AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SLASSQ +* .. +* .. Executable Statements .. +* +* Test input parameters. +* + INFO = 0 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. 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( 'SSYEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) + S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) + AMAX = MAX( AMAX, ABS( A(I, J) ) ) + END DO + S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) + AMAX = MAX( AMAX, ABS( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), ABS( A( J, J ) ) ) + AMAX = MAX( AMAX, ABS( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), ABS( A( I, J ) ) ) + S( J ) = MAX( S( J ), ABS( A( I, J ) ) ) + AMAX = MAX( AMAX, ABS( A( I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0 / S( J ) + END DO + + TOL = ONE / SQRT(2.0E0 * N) + + DO ITER = 1, MAX_ITER + SCALE = 0.0 + SUMSQ = 0.0 +* BETA = |A|S + DO I = 1, N + WORK(I) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + T = ABS( A( I, J ) ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + ABS( A( J, J ) ) * S( J ) + DO I = J+1, N + T = ABS( A( I, J ) ) + WORK( I ) = WORK( I ) + ABS( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + ABS( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0 + DO I = 2*N+1, 3*N + WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG + END DO + CALL SLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = ABS( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 + + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = ABS( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = ABS( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + + END DO + + END DO + + 999 CONTINUE + + SMLNUM = SLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT(AVG) + BASE = SLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) +* + END diff --git a/SRC/ssyev.f b/SRC/ssyev.f index 0e671c93..5a314438 100644 --- a/SRC/ssyev.f +++ b/SRC/ssyev.f @@ -1,6 +1,6 @@ SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssyevd.f b/SRC/ssyevd.f index ead05c5e..83f11147 100644 --- a/SRC/ssyevd.f +++ b/SRC/ssyevd.f @@ -1,7 +1,7 @@ SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssyevr.f b/SRC/ssyevr.f index 8f5ca484..2c9cffea 100644 --- a/SRC/ssyevr.f +++ b/SRC/ssyevr.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssyevx.f b/SRC/ssyevx.f index cb4acafa..2bb03993 100644 --- a/SRC/ssyevx.f +++ b/SRC/ssyevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssygs2.f b/SRC/ssygs2.f index 0f8deeb7..d21e92d3 100644 --- a/SRC/ssygs2.f +++ b/SRC/ssygs2.f @@ -1,6 +1,6 @@ SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssygst.f b/SRC/ssygst.f index 16060c09..5e132bb0 100644 --- a/SRC/ssygst.f +++ b/SRC/ssygst.f @@ -1,6 +1,6 @@ SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssygv.f b/SRC/ssygv.f index adc73def..58d55959 100644 --- a/SRC/ssygv.f +++ b/SRC/ssygv.f @@ -1,7 +1,7 @@ SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssygvd.f b/SRC/ssygvd.f index 4984fffb..ac2d45d1 100644 --- a/SRC/ssygvd.f +++ b/SRC/ssygvd.f @@ -1,7 +1,7 @@ SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssygvx.f b/SRC/ssygvx.f index bb2d118b..89760cf6 100644 --- a/SRC/ssygvx.f +++ b/SRC/ssygvx.f @@ -2,7 +2,7 @@ $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssyrfs.f b/SRC/ssyrfs.f index 4ac6581e..d817a04d 100644 --- a/SRC/ssyrfs.f +++ b/SRC/ssyrfs.f @@ -1,7 +1,7 @@ SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssyrfsx.f b/SRC/ssyrfsx.f new file mode 100644 index 00000000..90154e16 --- /dev/null +++ b/SRC/ssyrfsx.f @@ -0,0 +1,573 @@ + SUBROUTINE SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, IWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SSYRFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric indefinite, and +* provides error bounds and backward error estimates for the +* solution. In addition to normwise error bound, the code provides +* maximum componentwise error bound if possible. See comments for +* ERR_BNDS_N and ERR_BNDS_C for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) REAL array, dimension (LDAF,N) +* The factored form of the matrix A. AF contains the block +* diagonal matrix D and the multipliers used to obtain the +* factor U or L from the factorization A = U*D*U**T or A = +* L*D*L**T as computed by SSYTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by SSYTRF. +* +* S (input or output) REAL array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) REAL array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) REAL array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by SGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ITREF_DEFAULT, ITHRESH_DEFAULT, + $ COMPONENTWISE_DEFAULT + REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE, N_NORMS + REAL ANORM, RCOND_TMP + REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + REAL RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, SSYCON, SLA_SYRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL SLAMCH, SLANSY, SLA_SYRCOND + REAL SLAMCH, SLANSY, SLA_SYRCOND + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = REAL( N )*SLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0 + DO J = 1, NRHS + BERR( J ) = 0.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0 + DO J = 1, NRHS + BERR( J ) = 1.0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = SLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL SSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ IWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'D' ) + + CALL SLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK( N+1 ), WORK( 1 ), WORK( 2*N+1 ), WORK( 1 ), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0, SQRT( REAL( N ) ) )*SLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ -1, S, INFO, WORK, IWORK ) + ELSE + RCOND_TMP = SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ 0, S, INFO, WORK, IWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF (N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF (ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF (N_ERR_BNDS .GE. LA_LINRX_RCOND_I) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( SLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = SLA_SYRCOND( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ 1, X(1,J), INFO, WORK, IWORK ) + ELSE + RCOND_TMP = 0.0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of SSYRFSX +* + END diff --git a/SRC/ssysv.f b/SRC/ssysv.f index 42f5e4b2..d532e7a5 100644 --- a/SRC/ssysv.f +++ b/SRC/ssysv.f @@ -1,7 +1,7 @@ SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssysvx.f b/SRC/ssysvx.f index 04123b9b..9f8065ff 100644 --- a/SRC/ssysvx.f +++ b/SRC/ssysvx.f @@ -2,7 +2,7 @@ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssysvxx.f b/SRC/ssysvxx.f new file mode 100644 index 00000000..810a3259 --- /dev/null +++ b/SRC/ssysvxx.f @@ -0,0 +1,560 @@ + SUBROUTINE SSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + REAL RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ), IWORK( * ) + REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + REAL S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* SSYSVXX uses the diagonal pivoting factorization to compute the +* solution to a real system of linear equations A * X = B, where A +* is an N-by-N symmetric matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. SSYSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* SSYSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* SSYSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what SSYSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', real scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = U * D * U**T, if UPLO = 'U', or +* A = L * D * L**T, if UPLO = 'L', +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* 3. If some D(i,i)=0, so that D is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is +* less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(R) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) REAL array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) REAL array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T as computed by SSYTRF. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains details of the interchanges and the block +* structure of D, as determined by SSYTRF. If IPIV(k) > 0, +* then rows and columns k and IPIV(k) were interchanged and +* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +* then rows and columns k+1 and -IPIV(k) were interchanged +* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains details of the interchanges and the block +* structure of D, as determined by SSYTRF. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) REAL array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) REAL array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) REAL array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) REAL +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) REAL +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) REAL array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * slamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * slamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * slamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) REAL array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) REAL array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + REAL AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, SLAMCH, SLA_SYRPVGRW + LOGICAL LSAME + REAL SLAMCH, SLA_SYRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL SSYCON, SSYEQUB, SSYTRF, SSYTRS, + $ SLACPY, SLAQSY, XERBLA, SLASCL2, SSYRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = SLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in SSYRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until SSYRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME(UPLO, 'U') .AND. + $ .NOT.LSAME(UPLO, 'L') ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSYSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL SLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL SSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF ( N.GT.0 ) + $ RPVGRW = SLA_SYRPVGRW(UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF ( N.GT.0 ) + $ RPVGRW = SLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) +* +* Compute the solution matrix X. +* + CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL SSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL SSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL SLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of SSYSVXX +* + END diff --git a/SRC/ssytd2.f b/SRC/ssytd2.f index 697b2ba0..36b2b658 100644 --- a/SRC/ssytd2.f +++ b/SRC/ssytd2.f @@ -1,6 +1,6 @@ SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssytf2.f b/SRC/ssytf2.f index 3dfd766b..8e620b96 100644 --- a/SRC/ssytf2.f +++ b/SRC/ssytf2.f @@ -1,6 +1,6 @@ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssytrd.f b/SRC/ssytrd.f index 57a25239..75173f19 100644 --- a/SRC/ssytrd.f +++ b/SRC/ssytrd.f @@ -1,6 +1,6 @@ SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssytrf.f b/SRC/ssytrf.f index 38315d50..f9285a2e 100644 --- a/SRC/ssytrf.f +++ b/SRC/ssytrf.f @@ -1,6 +1,6 @@ SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssytri.f b/SRC/ssytri.f index 2540a565..e0f48ffd 100644 --- a/SRC/ssytri.f +++ b/SRC/ssytri.f @@ -1,6 +1,6 @@ SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ssytrs.f b/SRC/ssytrs.f index 6195c177..138f36c6 100644 --- a/SRC/ssytrs.f +++ b/SRC/ssytrs.f @@ -1,6 +1,6 @@ SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stbcon.f b/SRC/stbcon.f index 81ec16b6..a9a2dc77 100644 --- a/SRC/stbcon.f +++ b/SRC/stbcon.f @@ -1,7 +1,7 @@ SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stbrfs.f b/SRC/stbrfs.f index 6a020c38..4cdb6946 100644 --- a/SRC/stbrfs.f +++ b/SRC/stbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stbtrs.f b/SRC/stbtrs.f index 39e47d62..c77024b3 100644 --- a/SRC/stbtrs.f +++ b/SRC/stbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stfsm.f b/SRC/stfsm.f new file mode 100644 index 00000000..3c6438e8 --- /dev/null +++ b/SRC/stfsm.f @@ -0,0 +1,905 @@ + SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, + + B, LDB ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO + INTEGER LDB, M, N + REAL ALPHA +* .. +* .. Array Arguments .. + REAL A( 0: * ), B( 0: LDB-1, 0: * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for A in RFP Format. +* +* STFSM solves the matrix equation +* +* op( A )*X = alpha*B or X*op( A ) = alpha*B +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A'. +* +* A is in Rectangular Full Packed (RFP) Format. +* +* The matrix X is overwritten on B. +* +* Arguments +* ========== +* +* TRANSR - (input) CHARACTER +* = 'N': The Normal Form of RFP A is stored; +* = 'T': The Transpose Form of RFP A is stored. +* +* SIDE - (input) CHARACTER +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* Unchanged on exit. +* +* UPLO - (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix +* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER +* On entry, TRANS specifies the form of op( A ) to be used +* in the matrix multiplication as follows: +* +* TRANS = 'N' or 'n' op( A ) = A. +* +* TRANS = 'T' or 't' op( A ) = A'. +* +* Unchanged on exit. +* +* DIAG - (input) CHARACTER +* On entry, DIAG specifies whether or not RFP A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - (input) INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - (input) REAL. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - (input) REAL array, dimension (NT); +* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. +* RFP Format is described by TRANSR, UPLO and N as follows: +* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +* TRANSR = 'T' then RFP is the transpose of RFP A as +* defined when TRANSR = 'N'. The contents of RFP A are defined +* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT +* elements of upper packed A either in normal or +* transpose Format. If UPLO = 'L' the RFP A contains +* the NT elements of lower packed A either in normal or +* transpose Format. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is +* even and is N when is odd. +* See the Note below for more details. Unchanged on exit. +* +* B - (input/ouptut) REAL array, DIMENSION (LDB,N) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB - (input) INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, + + NOTRANS + INTEGER M1, M2, N1, N2, K, INFO, I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL SGEMM, STRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LSIDE = LSAME( SIDE, 'L' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STFSM ', -INFO ) + RETURN + END IF +* +* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + + RETURN +* +* Quick return when ALPHA.EQ.(0D+0) +* + IF( ALPHA.EQ.ZERO ) THEN + DO 20 J = 0, N - 1 + DO 10 I = 0, M - 1 + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* + IF( LSIDE ) THEN +* +* SIDE = 'L' +* +* A is M-by-M. +* If M is odd, set NISODD = .TRUE., and M1 and M2. +* If M is even, NISODD = .FALSE., and M. +* + IF( MOD( M, 2 ).EQ.0 ) THEN + MISODD = .FALSE. + K = M / 2 + ELSE + MISODD = .TRUE. + IF( LOWER ) THEN + M2 = M / 2 + M1 = M - M2 + ELSE + M1 = M / 2 + M2 = M - M1 + END IF + END IF +* + IF( MISODD ) THEN +* +* SIDE = 'L' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL STRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( 0 ), M, B, LDB ) + CALL SGEMM( 'N', 'N', M2, N, M1, -ONE, A( M1 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL STRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, + + A( M ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'T' +* + CALL STRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M ), M, B( M1, 0 ), LDB ) + CALL SGEMM( 'T', 'N', M1, N, M2, -ONE, A( M1 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, + + A( 0 ), M, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL STRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( M2 ), M, B, LDB ) + CALL SGEMM( 'T', 'N', M2, N, M1, -ONE, A( 0 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL STRSM( 'L', 'U', 'T', DIAG, M2, N, ONE, + + A( M1 ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'T' +* + CALL STRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M1 ), M, B( M1, 0 ), LDB ) + CALL SGEMM( 'N', 'N', M1, N, M2, -ONE, A( 0 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'L', 'T', DIAG, M1, N, ONE, + + A( M2 ), M, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'N' +* + CALL STRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + + A( 0 ), M1, B, LDB ) + CALL SGEMM( 'T', 'N', M2, N, M1, -ONE, A( M1*M1 ), + + M1, B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL STRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, + + A( 1 ), M1, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'T' +* + CALL STRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, + + A( 1 ), M1, B( M1, 0 ), LDB ) + CALL SGEMM( 'N', 'N', M1, N, M2, -ONE, A( M1*M1 ), + + M1, B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, + + A( 0 ), M1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'N' +* + CALL STRSM( 'L', 'U', 'T', DIAG, M1, N, ALPHA, + + A( M2*M2 ), M2, B, LDB ) + CALL SGEMM( 'N', 'N', M2, N, M1, -ONE, A( 0 ), M2, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL STRSM( 'L', 'L', 'N', DIAG, M2, N, ONE, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'T' +* + CALL STRSM( 'L', 'L', 'T', DIAG, M2, N, ALPHA, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) + CALL SGEMM( 'T', 'N', M1, N, M2, -ONE, A( 0 ), M2, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'U', 'N', DIAG, M1, N, ONE, + + A( M2*M2 ), M2, B, LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( 1 ), M+1, B, LDB ) + CALL SGEMM( 'N', 'N', K, N, K, -ONE, A( K+1 ), + + M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ONE, + + A( 0 ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'T' +* + CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( 0 ), M+1, B( K, 0 ), LDB ) + CALL SGEMM( 'T', 'N', K, N, K, -ONE, A( K+1 ), + + M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ONE, + + A( 1 ), M+1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( K+1 ), M+1, B, LDB ) + CALL SGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), M+1, + + B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ONE, + + A( K ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'T' + CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( K ), M+1, B( K, 0 ), LDB ) + CALL SGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), M+1, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ONE, + + A( K+1 ), M+1, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'N' +* + CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, + + A( K ), K, B, LDB ) + CALL SGEMM( 'T', 'N', K, N, K, -ONE, + + A( K*( K+1 ) ), K, B, LDB, ALPHA, + + B( K, 0 ), LDB ) + CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ONE, + + A( 0 ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'T' +* + CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, + + A( 0 ), K, B( K, 0 ), LDB ) + CALL SGEMM( 'N', 'N', K, N, K, -ONE, + + A( K*( K+1 ) ), K, B( K, 0 ), LDB, + + ALPHA, B, LDB ) + CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ONE, + + A( K ), K, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'N' +* + CALL STRSM( 'L', 'U', 'T', DIAG, K, N, ALPHA, + + A( K*( K+1 ) ), K, B, LDB ) + CALL SGEMM( 'N', 'N', K, N, K, -ONE, A( 0 ), K, B, + + LDB, ALPHA, B( K, 0 ), LDB ) + CALL STRSM( 'L', 'L', 'N', DIAG, K, N, ONE, + + A( K*K ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'T' +* + CALL STRSM( 'L', 'L', 'T', DIAG, K, N, ALPHA, + + A( K*K ), K, B( K, 0 ), LDB ) + CALL SGEMM( 'T', 'N', K, N, K, -ONE, A( 0 ), K, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL STRSM( 'L', 'U', 'N', DIAG, K, N, ONE, + + A( K*( K+1 ) ), K, B, LDB ) +* + END IF +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' +* +* A is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and K. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + K = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* SIDE = 'R' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL STRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, + + A( N ), N, B( 0, N1 ), LDB ) + CALL SGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( N1 ), N, ALPHA, B( 0, 0 ), + + LDB ) + CALL STRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, + + A( 0 ), N, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'T' +* + CALL STRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, + + A( 0 ), N, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( N1 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL STRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, + + A( N ), N, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL STRSM( 'R', 'L', 'T', DIAG, M, N1, ALPHA, + + A( N2 ), N, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( 0 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL STRSM( 'R', 'U', 'N', DIAG, M, N2, ONE, + + A( N1 ), N, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'T' +* + CALL STRSM( 'R', 'U', 'T', DIAG, M, N2, ALPHA, + + A( N1 ), N, B( 0, N1 ), LDB ) + CALL SGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) + CALL STRSM( 'R', 'L', 'N', DIAG, M, N1, ONE, + + A( N2 ), N, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is odd, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'N' +* + CALL STRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( 1 ), N1, B( 0, N1 ), LDB ) + CALL SGEMM( 'N', 'T', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), + + LDB ) + CALL STRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, + + A( 0 ), N1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and +* TRANS = 'T' +* + CALL STRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( 0 ), N1, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'N', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), + + LDB ) + CALL STRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, + + A( 1 ), N1, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'N' +* + CALL STRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'T', M, N2, N1, -ONE, B( 0, 0 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), + + LDB ) + CALL STRSM( 'R', 'L', 'T', DIAG, M, N2, ONE, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and +* TRANS = 'T' +* + CALL STRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) + CALL SGEMM( 'N', 'N', M, N1, N2, -ONE, B( 0, N1 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), + + LDB ) + CALL STRSM( 'R', 'U', 'T', DIAG, M, N1, ONE, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, + + A( 0 ), N+1, B( 0, K ), LDB ) + CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ONE, + + A( 1 ), N+1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'T' +* + CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, + + A( 1 ), N+1, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ONE, + + A( 0 ), N+1, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ALPHA, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ONE, + + A( K ), N+1, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'T' +* + CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ALPHA, + + A( K ), N+1, B( 0, K ), LDB ) + CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ONE, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is even, and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'N' +* + CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( 0 ), K, B( 0, K ), LDB ) + CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, K ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, 0 ), LDB ) + CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ONE, + + A( K ), K, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', +* and TRANS = 'T' +* + CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( K ), K, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, K ), LDB ) + CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ONE, + + A( 0 ), K, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'N' +* + CALL STRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) + CALL SGEMM( 'N', 'T', M, K, K, -ONE, B( 0, 0 ), + + LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) + CALL STRSM( 'R', 'L', 'T', DIAG, M, K, ONE, + + A( K*K ), K, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', +* and TRANS = 'T' +* + CALL STRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( K*K ), K, B( 0, K ), LDB ) + CALL SGEMM( 'N', 'N', M, K, K, -ONE, B( 0, K ), + + LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) + CALL STRSM( 'R', 'U', 'T', DIAG, M, K, ONE, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + END IF + END IF +* + RETURN +* +* End of STFSM +* + END diff --git a/SRC/stftri.f b/SRC/stftri.f new file mode 100644 index 00000000..e75727b4 --- /dev/null +++ b/SRC/stftri.f @@ -0,0 +1,407 @@ + SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO, DIAG + INTEGER INFO, N +* .. +* .. Array Arguments .. + REAL A( 0: * ) +* .. +* +* Purpose +* ======= +* +* STFTRI computes the inverse of a triangular matrix A stored in RFP +* format. +* +* This is a Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'T': The Transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* DIAG (input) CHARACTER +* = 'N': A is non-unit triangular; +* = 'U': A is unit triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) REAL array, dimension (NT); +* NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian +* Positive Definite matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is +* the transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A; If UPLO = 'L' the RFP A contains the nt +* elements of lower packed A. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is +* even and N is odd. See the Note below for more details. +* +* On exit, the (triangular) inverse of the original matrix, in +* the same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, A(i,i) is exactly zero. The triangular +* matrix is singular and its inverse can not be computed. +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, STRMM, STRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL STRTRI( 'L', DIAG, N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'L', 'N', DIAG, N2, N1, -ONE, A( 0 ), + + N, A( N1 ), N ) + CALL STRTRI( 'U', DIAG, N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'U', 'T', DIAG, N2, N1, ONE, A( N ), N, + + A( N1 ), N ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL STRTRI( 'L', DIAG, N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'L', 'T', DIAG, N1, N2, -ONE, A( N2 ), + + N, A( 0 ), N ) + CALL STRTRI( 'U', DIAG, N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'U', 'N', DIAG, N1, N2, ONE, A( N1 ), + + N, A( 0 ), N ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) +* + CALL STRTRI( 'U', DIAG, N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'U', 'N', DIAG, N1, N2, -ONE, A( 0 ), + + N1, A( N1*N1 ), N1 ) + CALL STRTRI( 'L', DIAG, N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'L', 'T', DIAG, N1, N2, ONE, A( 1 ), + + N1, A( N1*N1 ), N1 ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) +* + CALL STRTRI( 'U', DIAG, N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'U', 'T', DIAG, N2, N1, -ONE, + + A( N2*N2 ), N2, A( 0 ), N2 ) + CALL STRTRI( 'L', DIAG, N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'L', 'N', DIAG, N2, N1, ONE, + + A( N1*N2 ), N2, A( 0 ), N2 ) + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL STRTRI( 'L', DIAG, K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'L', 'N', DIAG, K, K, -ONE, A( 1 ), + + N+1, A( K+1 ), N+1 ) + CALL STRTRI( 'U', DIAG, K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'U', 'T', DIAG, K, K, ONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL STRTRI( 'L', DIAG, K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'L', 'T', DIAG, K, K, -ONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL STRTRI( 'U', DIAG, K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'U', 'N', DIAG, K, K, ONE, A( K ), N+1, + + A( 0 ), N+1 ) + END IF + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL STRTRI( 'U', DIAG, K, A( K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'U', 'N', DIAG, K, K, -ONE, A( K ), K, + + A( K*( K+1 ) ), K ) + CALL STRTRI( 'L', DIAG, K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'L', 'T', DIAG, K, K, ONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL STRTRI( 'U', DIAG, K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'R', 'U', 'T', DIAG, K, K, -ONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL STRTRI( 'L', DIAG, K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL STRMM( 'L', 'L', 'N', DIAG, K, K, ONE, A( K*K ), K, + + A( 0 ), K ) + END IF + END IF + END IF +* + RETURN +* +* End of STFTRI +* + END diff --git a/SRC/stfttp.f b/SRC/stfttp.f new file mode 100644 index 00000000..e582ff86 --- /dev/null +++ b/SRC/stfttp.f @@ -0,0 +1,453 @@ + SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + REAL AP( 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* STFTTP copies a triangular matrix A from rectangular full packed +* format (TF) to standard packed format (TP). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'T': ARF is in Transpose format; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ARF (input) REAL array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* AP (output) REAL array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STFTTP', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + AP( 0 ) = ARF( 0 ) + ELSE + AP( 0 ) = ARF( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of STFTTP +* + END diff --git a/SRC/stfttr.f b/SRC/stfttr.f new file mode 100644 index 00000000..c198b478 --- /dev/null +++ b/SRC/stfttr.f @@ -0,0 +1,430 @@ + SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + REAL A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* STFTTR copies a triangular matrix A from rectangular full packed +* format (TF) to standard full format (TR). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'T': ARF is in Transpose format. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrices ARF and A. N >= 0. +* +* ARF (input) REAL array, dimension (N*(N+1)/2). +* On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') +* matrix A in RFP format. See the "Notes" below for more +* details. +* +* A (output) REAL array, dimension (LDA,N) +* On exit, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT, NX2, NP1X2 + INTEGER I, J, L, IJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STFTTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + A( 0, 0 ) = ARF( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + A( N2+J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + A( J-N1, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + A( I, N1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + A( N2+J, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + A( K+J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + A( J-K, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + J = K + DO I = K, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + A( I, K+1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + A( J, I ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + A( K+1+J, L ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* Note that here, on exit of the loop, J = K-1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of STFTTR +* + END diff --git a/SRC/stgevc.f b/SRC/stgevc.f index 3045c129..0b580f19 100644 --- a/SRC/stgevc.f +++ b/SRC/stgevc.f @@ -1,7 +1,7 @@ SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stgex2.f b/SRC/stgex2.f index 9b0afe8c..8cb944c4 100644 --- a/SRC/stgex2.f +++ b/SRC/stgex2.f @@ -1,7 +1,7 @@ SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, N1, N2, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stgexc.f b/SRC/stgexc.f index fab2be4f..fee6f64f 100644 --- a/SRC/stgexc.f +++ b/SRC/stgexc.f @@ -1,7 +1,7 @@ SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stgsen.f b/SRC/stgsen.f index 9b2054a5..5843b12e 100644 --- a/SRC/stgsen.f +++ b/SRC/stgsen.f @@ -2,7 +2,7 @@ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, $ PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/stgsja.f b/SRC/stgsja.f index be29a7a4..d090cf91 100644 --- a/SRC/stgsja.f +++ b/SRC/stgsja.f @@ -2,7 +2,7 @@ $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stgsna.f b/SRC/stgsna.f index f16b49b6..732f4f32 100644 --- a/SRC/stgsna.f +++ b/SRC/stgsna.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stgsy2.f b/SRC/stgsy2.f index 9fa0e16e..2ba3dd70 100644 --- a/SRC/stgsy2.f +++ b/SRC/stgsy2.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ IWORK, PQ, INFO ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/stgsyl.f b/SRC/stgsyl.f index 10d35951..77f68c87 100644 --- a/SRC/stgsyl.f +++ b/SRC/stgsyl.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stpcon.f b/SRC/stpcon.f index 46eb8b61..3e357a88 100644 --- a/SRC/stpcon.f +++ b/SRC/stpcon.f @@ -1,7 +1,7 @@ SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stprfs.f b/SRC/stprfs.f index 7d008825..5e4eb7e0 100644 --- a/SRC/stprfs.f +++ b/SRC/stprfs.f @@ -1,7 +1,7 @@ SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stptri.f b/SRC/stptri.f index 4d30c74f..2e8e8963 100644 --- a/SRC/stptri.f +++ b/SRC/stptri.f @@ -1,6 +1,6 @@ SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stptrs.f b/SRC/stptrs.f index 201f83f1..8d0ea113 100644 --- a/SRC/stptrs.f +++ b/SRC/stptrs.f @@ -1,6 +1,6 @@ SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stpttf.f b/SRC/stpttf.f new file mode 100644 index 00000000..be98d07e --- /dev/null +++ b/SRC/stpttf.f @@ -0,0 +1,439 @@ + SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + REAL AP( 0: * ), ARF( 0: * ) +* +* Purpose +* ======= +* +* STPTTF copies a triangular matrix A from standard packed format (TP) +* to rectangular full packed format (TF). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal format is wanted; +* = 'T': ARF in Conjugate-transpose format is wanted. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) REAL array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* ARF (output) REAL array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = AP( 0 ) + ELSE + ARF( 0 ) = AP( 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of STPTTF +* + END diff --git a/SRC/stpttr.f b/SRC/stpttr.f new file mode 100644 index 00000000..d500cf48 --- /dev/null +++ b/SRC/stpttr.f @@ -0,0 +1,114 @@ + SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* STPTTR copies a triangular matrix A from standard packed format (TP) +* to standard full format (TR). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular. +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) REAL array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* A (output) REAL array, dimension ( LDA, N ) +* On exit, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STPTTR', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + END IF +* +* + RETURN +* +* End of STPTTR +* + END diff --git a/SRC/strcon.f b/SRC/strcon.f index c2b088b5..fd663ee6 100644 --- a/SRC/strcon.f +++ b/SRC/strcon.f @@ -1,7 +1,7 @@ SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strevc.f b/SRC/strevc.f index 77e73cc5..3a57f3f7 100644 --- a/SRC/strevc.f +++ b/SRC/strevc.f @@ -1,7 +1,7 @@ SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strexc.f b/SRC/strexc.f index 7db8820d..48d8b0ab 100644 --- a/SRC/strexc.f +++ b/SRC/strexc.f @@ -1,7 +1,7 @@ SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strrfs.f b/SRC/strrfs.f index 1cb4d67d..d737b26c 100644 --- a/SRC/strrfs.f +++ b/SRC/strrfs.f @@ -1,7 +1,7 @@ SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strsen.f b/SRC/strsen.f index 249220a2..0800c19b 100644 --- a/SRC/strsen.f +++ b/SRC/strsen.f @@ -1,7 +1,7 @@ SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strsna.f b/SRC/strsna.f index ddfa0e3f..570a0172 100644 --- a/SRC/strsna.f +++ b/SRC/strsna.f @@ -2,7 +2,7 @@ $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strsyl.f b/SRC/strsyl.f index e9c5ee79..7d1610fe 100644 --- a/SRC/strsyl.f +++ b/SRC/strsyl.f @@ -1,7 +1,7 @@ SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strti2.f b/SRC/strti2.f index 79ca5c8b..1085a8e3 100644 --- a/SRC/strti2.f +++ b/SRC/strti2.f @@ -1,6 +1,6 @@ SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strtri.f b/SRC/strtri.f index 3bda8ac3..b758043d 100644 --- a/SRC/strtri.f +++ b/SRC/strtri.f @@ -1,6 +1,6 @@ SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strtrs.f b/SRC/strtrs.f index df36982d..cbaecad7 100644 --- a/SRC/strtrs.f +++ b/SRC/strtrs.f @@ -1,7 +1,7 @@ SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/strttf.f b/SRC/strttf.f new file mode 100644 index 00000000..04db17b0 --- /dev/null +++ b/SRC/strttf.f @@ -0,0 +1,427 @@ + SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + REAL A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* STRTTF copies a triangular matrix A from standard full format (TR) +* to rectangular full packed format (TF) . +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal form is wanted; +* = 'T': ARF in Transpose form is wanted. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) REAL array, dimension (LDA,N). +* On entry, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the matrix A. LDA >= max(1,N). +* +* ARF (output) REAL array, dimension (NT). +* NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* even. We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* the transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* the transpose of the last three columns of AP lower. +* This covers the case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* 03 04 05 33 43 53 +* 13 14 15 00 44 54 +* 23 24 25 10 11 55 +* 33 34 35 20 21 22 +* 00 44 45 30 31 32 +* 01 11 55 40 41 42 +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We first consider Rectangular Full Packed (RFP) Format when N is +* odd. We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* the transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* the transpose of the last two columns of AP lower. +* This covers the case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* 02 03 04 00 33 43 +* 12 13 14 10 11 44 +* 22 23 24 20 21 22 +* 00 33 34 30 31 32 +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'T'. RFP A in both UPLO cases is just the +* transpose of RFP A above. One therefore gets: +* +* RFP A RFP A +* +* 02 12 22 00 01 00 10 20 30 40 50 +* 03 13 23 33 11 33 11 21 31 41 51 +* 04 14 24 34 44 43 44 22 32 42 52 +* +* Reference +* ========= +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'T' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'STRTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + ARF( 0 ) = A( 0, 0 ) + END IF + RETURN + END IF +* +* Size of array ARF(0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + ARF( IJ ) = A( N2+J, I ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + ARF( IJ ) = A( J-N1, L ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + ARF( IJ ) = A( I, N1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is odd, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + ARF( IJ ) = A( N2+J, L ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + ARF( IJ ) = A( K+J, I ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + ARF( IJ ) = A( J-K, L ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'T' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'T', and UPLO = 'L' +* + IJ = 0 + J = K + DO I = K, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + ARF( IJ ) = A( I, K+1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* N is even, TRANSR = 'T', and UPLO = 'U' +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + ARF( IJ ) = A( J, I ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + ARF( IJ ) = A( K+1+J, L ) + IJ = IJ + 1 + END DO + END DO +* Note that here, on exit of the loop, J = K-1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of STRTTF +* + END diff --git a/SRC/strttp.f b/SRC/strttp.f new file mode 100644 index 00000000..51ad2f39 --- /dev/null +++ b/SRC/strttp.f @@ -0,0 +1,113 @@ + SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- and Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* STRTTP copies a triangular matrix A from full format (TR) to standard +* packed format (TP). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular. +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrices AP and A. N >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* On exit, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AP (output) REAL array, dimension (N*(N+1)/2 +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) 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( 'STRTTP', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + END IF +* + RETURN +* +* End of STRTTP +* + END diff --git a/SRC/stzrqf.f b/SRC/stzrqf.f index d1a54558..e8749c0c 100644 --- a/SRC/stzrqf.f +++ b/SRC/stzrqf.f @@ -1,6 +1,6 @@ SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/stzrzf.f b/SRC/stzrzf.f index 33459c5c..14894ee4 100644 --- a/SRC/stzrzf.f +++ b/SRC/stzrzf.f @@ -1,6 +1,6 @@ SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/xerbla.f b/SRC/xerbla.f index 99ca6aa8..cef5464d 100644 --- a/SRC/xerbla.f +++ b/SRC/xerbla.f @@ -1,11 +1,11 @@ SUBROUTINE XERBLA( SRNAME, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. - CHARACTER*(*) SRNAME + CHARACTER*(*) SRNAME INTEGER INFO * .. * @@ -31,13 +31,12 @@ * * ===================================================================== * -* .. External Functions .. - INTEGER ILA_LEN_TRIM - EXTERNAL ILA_LEN_TRIM +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM * .. * .. Executable Statements .. * - WRITE( *, FMT = 9999 )SRNAME(1:ILA_LEN_TRIM(SRNAME)), INFO + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO * STOP * diff --git a/SRC/xerbla_array.f b/SRC/xerbla_array.f index 30a91362..57cd98a9 100644 --- a/SRC/xerbla_array.f +++ b/SRC/xerbla_array.f @@ -1,7 +1,7 @@ SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO) ! -! -- LAPACK auxiliary routine (version 3.1) -- -! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +! -- LAPACK auxiliary routine (version 3.0) -- +! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., ! September 19, 2006 ! IMPLICIT NONE @@ -54,7 +54,7 @@ INTEGER I ! .. ! .. Local Arrays .. - CHARACTER(32) SRNAME + CHARACTER*32 SRNAME ! .. ! .. Intrinsic Functions .. INTRINSIC MIN, LEN @@ -64,11 +64,11 @@ ! .. ! .. Executable Statements .. SRNAME = '' - DO I = 1, MIN(SRNAME_LEN, LEN(SRNAME)) - SRNAME(I:I) = SRNAME_ARRAY(I) + DO I = 1, MIN( SRNAME_LEN, LEN( SRNAME ) ) + SRNAME( I:I ) = SRNAME_ARRAY( I ) END DO - CALL XERBLA(SRNAME, INFO) + CALL XERBLA( SRNAME, INFO ) RETURN END diff --git a/SRC/zbdsqr.f b/SRC/zbdsqr.f index f9086be5..64be5273 100644 --- a/SRC/zbdsqr.f +++ b/SRC/zbdsqr.f @@ -1,7 +1,7 @@ SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, $ LDU, C, LDC, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zcgesv.f b/SRC/zcgesv.f index 5a6d5c28..a6e6aa8e 100644 --- a/SRC/zcgesv.f +++ b/SRC/zcgesv.f @@ -1,49 +1,46 @@ SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, - + SWORK, ITER, INFO) + + SWORK, RWORK, ITER, INFO ) * -* -- LAPACK PROTOTYPE driver routine (version 3.1.1) -- +* -- LAPACK PROTOTYPE driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * * .. -* .. WARNING: PROTOTYPE .. -* This is an LAPACK PROTOTYPE routine which means that the -* interface of this routine is likely to be changed in the future -* based on community feedback. -* -* .. * .. Scalar Arguments .. - INTEGER INFO,ITER,LDA,LDB,LDX,N,NRHS + INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS * .. * .. Array Arguments .. - INTEGER IPIV(*) - COMPLEX SWORK(*) - COMPLEX*16 A(LDA,*),B(LDB,*),WORK(N,*),X(LDX,*) + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX SWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( N, * ), + + X( LDX, * ) * .. * * Purpose * ======= * -* ZCGESV computes the solution to a real system of linear equations +* ZCGESV computes the solution to a complex system of linear equations * A * X = B, * where A is an N-by-N matrix and X and B are N-by-NRHS matrices. * -* ZCGESV first attempts to factorize the matrix in SINGLE COMPLEX PRECISION -* and use this factorization within an iterative refinement procedure to -* produce a solution with DOUBLE COMPLEX PRECISION normwise backward error -* quality (see below). If the approach fails the method switches to a -* DOUBLE COMPLEX PRECISION factorization and solve. +* ZCGESV first attempts to factorize the matrix in COMPLEX and use this +* factorization within an iterative refinement procedure to produce a +* solution with COMPLEX*16 normwise backward error quality (see below). +* If the approach fails the method switches to a COMPLEX*16 +* factorization and solve. * * The iterative refinement is not going to be a winning strategy if -* the ratio SINGLE PRECISION performance over DOUBLE PRECISION performance -* is too small. A reasonable strategy should take the number of right-hand -* sides and the size of the matrix into account. This might be done with a -* call to ILAENV in the future. Up to now, we always try iterative refinement. +* the ratio COMPLEX performance over COMPLEX*16 performance is too +* small. A reasonable strategy should take the number of right-hand +* sides and the size of the matrix into account. This might be done +* with a call to ILAENV in the future. Up to now, we always try +* iterative refinement. * * The iterative refinement process is stopped if * ITER > ITERMAX * or for all the RHS we have: -* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX +* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX * where * o ITER is the number of the current iteration in the iterative * refinement process @@ -51,7 +48,8 @@ * o XNRM is the infinity-norm of the solution * o ANRM is the infinity-operator-norm of the matrix A * o EPS is the machine epsilon returned by DLAMCH('Epsilon') -* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively. +* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 +* respectively. * * Arguments * ========= @@ -80,12 +78,12 @@ * IPIV (output) INTEGER array, dimension (N) * The pivot indices that define the permutation matrix P; * row i of the matrix was interchanged with row IPIV(i). -* Corresponds either to the single precision factorization -* (if INFO.EQ.0 and ITER.GE.0) or the double precision +* Corresponds either to the single precision factorization +* (if INFO.EQ.0 and ITER.GE.0) or the double precision * factorization (if INFO.EQ.0 and ITER.LT.0). * * B (input) COMPLEX*16 array, dimension (LDB,NRHS) -* The N-by-NRHS matrix of right hand side matrix B. +* The N-by-NRHS right hand side matrix B. * * LDB (input) INTEGER * The leading dimension of the array B. LDB >= max(1,N). @@ -100,17 +98,19 @@ * This array is used to hold the residual vectors. * * SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS)) -* This array is used to use the single precision matrix and the +* This array is used to use the single precision matrix and the * right-hand sides or solutions in single precision. * +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* * ITER (output) INTEGER -* < 0: iterative refinement has failed, double precision +* < 0: iterative refinement has failed, COMPLEX*16 * factorization has been performed -* -1 : taking into account machine parameters, N, NRHS, it -* is a priori not worth working in SINGLE PRECISION -* -2 : overflow of an entry when moving from double to -* SINGLE PRECISION -* -3 : failure of SGETRF +* -1 : the routine fell back to full precision for +* implementation- or machine-specific reasons +* -2 : narrowing the precision induced an overflow, +* the routine fell back to full precision +* -3 : failure of CGETRF * -31: stop the iterative refinement after the 30th * iterations * > 0: iterative refinement has been sucessfully used. @@ -119,34 +119,43 @@ * INFO (output) INTEGER * = 0: successful exit * < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is -* exactly zero. The factorization has been completed, -* but the factor U is exactly singular, so the solution +* > 0: if INFO = i, U(i,i) computed in COMPLEX*16 is exactly +* zero. The factorization has been completed, but the +* factor U is exactly singular, so the solution * could not be computed. * * ========= * * .. Parameters .. - COMPLEX*16 NEGONE,ONE - PARAMETER (NEGONE=(-1.0D+00,0.0D+00),ONE=(1.0D+00,0.0D+00)) + LOGICAL DOITREF + PARAMETER ( DOITREF = .TRUE. ) +* + INTEGER ITERMAX + PARAMETER ( ITERMAX = 30 ) +* + DOUBLE PRECISION BWDMAX + PARAMETER ( BWDMAX = 1.0E+00 ) +* + COMPLEX*16 NEGONE, ONE + PARAMETER ( NEGONE = ( -1.0D+00, 0.0D+00 ), + + ONE = ( 1.0D+00, 0.0D+00 ) ) * * .. Local Scalars .. - LOGICAL DOITREF - INTEGER I,IITER,ITERMAX,OK,PTSA,PTSX - DOUBLE PRECISION ANRM,BWDMAX,CTE,EPS,RNRM,XNRM - COMPLEX*16 ZDUM + INTEGER I, IITER, PTSA, PTSX + DOUBLE PRECISION ANRM, CTE, EPS, RNRM, XNRM + COMPLEX*16 ZDUM * * .. External Subroutines .. - EXTERNAL CGETRS,CGETRF,CLAG2Z,XERBLA,ZAXPY, - $ ZGEMM,ZLACPY,ZLAG2C + EXTERNAL CGETRS, CGETRF, CLAG2Z, XERBLA, ZAXPY, ZGEMM, + + ZLACPY, ZLAG2C * .. * .. External Functions .. - INTEGER IZAMAX - DOUBLE PRECISION DLAMCH,ZLANGE - EXTERNAL IZAMAX,DLAMCH,ZLANGE + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, ZLANGE + EXTERNAL IZAMAX, DLAMCH, ZLANGE * .. * .. Intrinsic Functions .. - INTRINSIC ABS,DBLE,MAX,SQRT + INTRINSIC ABS, DBLE, MAX, SQRT * .. * .. Statement Functions .. DOUBLE PRECISION CABS1 @@ -156,51 +165,47 @@ * .. * .. Executable Statements .. * - ITERMAX = 30 - BWDMAX = 1.0E+00 - DOITREF = .TRUE. -* - OK = 0 INFO = 0 ITER = 0 * * Test the input parameters. * - IF (N.LT.0) THEN - INFO = -1 - ELSE IF (NRHS.LT.0) THEN - INFO = -2 - ELSE IF (LDA.LT.MAX(1,N)) THEN - INFO = -4 - ELSE IF (LDB.LT.MAX(1,N)) THEN - INFO = -7 - ELSE IF (LDX.LT.MAX(1,N)) THEN - INFO = -9 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 END IF - IF (INFO.NE.0) THEN - CALL XERBLA('ZCGESV',-INFO) - RETURN + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZCGESV', -INFO ) + RETURN END IF * * Quick return if (N.EQ.0). * - IF (N.EQ.0) RETURN + IF( N.EQ.0 ) + + RETURN * * Skip single precision iterative refinement if a priori slower * than double precision factorization. * - IF (.NOT.DOITREF) THEN - ITER = -1 - GO TO 40 + IF( .NOT.DOITREF ) THEN + ITER = -1 + GO TO 40 END IF * * Compute some constants. * - ANRM = ZLANGE('I',N,N,A,LDA,WORK) - EPS = DLAMCH('Epsilon') - CTE = ANRM*EPS*SQRT(DBLE(N))*BWDMAX + ANRM = ZLANGE( 'I', N, N, A, LDA, RWORK ) + EPS = DLAMCH( 'Epsilon' ) + CTE = ANRM*EPS*SQRT( DBLE( N ) )*BWDMAX * -* Set the pointers PTSA, PTSX for referencing SA and SX in SWORK. +* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. * PTSA = 1 PTSX = PTSA + N*N @@ -208,58 +213,59 @@ * Convert B from double precision to single precision and store the * result in SX. * - CALL ZLAG2C(N,NRHS,B,LDB,SWORK(PTSX),N,INFO) + CALL ZLAG2C( N, NRHS, B, LDB, SWORK( PTSX ), N, INFO ) * - IF (INFO.NE.0) THEN - ITER = -2 - GO TO 40 + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 END IF * * Convert A from double precision to single precision and store the * result in SA. * - CALL ZLAG2C(N,N,A,LDA,SWORK(PTSA),N,INFO) + CALL ZLAG2C( N, N, A, LDA, SWORK( PTSA ), N, INFO ) * - IF (INFO.NE.0) THEN - ITER = -2 - GO TO 40 + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 END IF * * Compute the LU factorization of SA. * - CALL CGETRF(N,N,SWORK(PTSA),N,IPIV,INFO) + CALL CGETRF( N, N, SWORK( PTSA ), N, IPIV, INFO ) * - IF (INFO.NE.0) THEN - ITER = -3 - GO TO 40 + IF( INFO.NE.0 ) THEN + ITER = -3 + GO TO 40 END IF * * Solve the system SA*SX = SB. * - CALL CGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV, - + SWORK(PTSX),N,INFO) + CALL CGETRS( 'No transpose', N, NRHS, SWORK( PTSA ), N, IPIV, + + SWORK( PTSX ), N, INFO ) * * Convert SX back to double precision * - CALL CLAG2Z(N,NRHS,SWORK(PTSX),N,X,LDX,INFO) + CALL CLAG2Z( N, NRHS, SWORK( PTSX ), N, X, LDX, INFO ) * * Compute R = B - AX (R is WORK). * - CALL ZLACPY('All',N,NRHS,B,LDB,WORK,N) + CALL ZLACPY( 'All', N, NRHS, B, LDB, WORK, N ) * - CALL ZGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,LDA,X, - + LDX,ONE,WORK,N) + CALL ZGEMM( 'No Transpose', 'No Transpose', N, NRHS, N, NEGONE, A, + + LDA, X, LDX, ONE, WORK, N ) * -* Check whether the NRHS normwised backward errors satisfy the +* Check whether the NRHS normwise backward errors satisfy the * stopping criterion. If yes, set ITER=0 and return. * - DO I = 1,NRHS - XNRM = CABS1(X(IZAMAX(N,X(1,I),1),I)) - RNRM = CABS1(WORK(IZAMAX(N,WORK(1,I),1),I)) - IF (RNRM.GT.XNRM*CTE) GOTO 10 + DO I = 1, NRHS + XNRM = CABS1( X( IZAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = CABS1( WORK( IZAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 10 END DO * -* If we are here, the NRHS normwised backward errors satisfy the +* If we are here, the NRHS normwise backward errors satisfy the * stopping criterion. We are good to exit. * ITER = 0 @@ -267,54 +273,57 @@ * 10 CONTINUE * - DO 30 IITER = 1,ITERMAX + DO 30 IITER = 1, ITERMAX * -* Convert R (in WORK) from double precision to single precision -* and store the result in SX. +* Convert R (in WORK) from double precision to single precision +* and store the result in SX. * - CALL ZLAG2C(N,NRHS,WORK,N,SWORK(PTSX),N,INFO) + CALL ZLAG2C( N, NRHS, WORK, N, SWORK( PTSX ), N, INFO ) * - IF (INFO.NE.0) THEN - ITER = -2 - GO TO 40 - END IF + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF * -* Solve the system SA*SX = SR. +* Solve the system SA*SX = SR. * - CALL CGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV, - + SWORK(PTSX),N,INFO) + CALL CGETRS( 'No transpose', N, NRHS, SWORK( PTSA ), N, IPIV, + + SWORK( PTSX ), N, INFO ) * -* Convert SX back to double precision and update the current -* iterate. +* Convert SX back to double precision and update the current +* iterate. * - CALL CLAG2Z(N,NRHS,SWORK(PTSX),N,WORK,N,INFO) + CALL CLAG2Z( N, NRHS, SWORK( PTSX ), N, WORK, N, INFO ) * - CALL ZAXPY(N*NRHS,ONE,WORK,1,X,1) + DO I = 1, NRHS + CALL ZAXPY( N, ONE, WORK( 1, I ), 1, X( 1, I ), 1 ) + END DO * -* Compute R = B - AX (R is WORK). +* Compute R = B - AX (R is WORK). * - CALL ZLACPY('All',N,NRHS,B,LDB,WORK,N) + CALL ZLACPY( 'All', N, NRHS, B, LDB, WORK, N ) * - CALL ZGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A, - + LDA,X,LDX,ONE,WORK,N) + CALL ZGEMM( 'No Transpose', 'No Transpose', N, NRHS, N, NEGONE, + + A, LDA, X, LDX, ONE, WORK, N ) * -* Check whether the NRHS normwised backward errors satisfy the -* stopping criterion. If yes, set ITER=IITER>0 and return. +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=IITER>0 and return. * - DO I = 1,NRHS - XNRM = CABS1(X(IZAMAX(N,X(1,I),1),I)) - RNRM = CABS1(WORK(IZAMAX(N,WORK(1,I),1),I)) - IF (RNRM.GT.XNRM*CTE) GOTO 20 - END DO + DO I = 1, NRHS + XNRM = CABS1( X( IZAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = CABS1( WORK( IZAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 20 + END DO * -* If we are here, the NRHS normwised backward errors satisfy the -* stopping criterion, we are good to exit. +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion, we are good to exit. * - ITER = IITER + ITER = IITER * - RETURN + RETURN * - 20 CONTINUE + 20 CONTINUE * 30 CONTINUE * @@ -330,13 +339,14 @@ * Single-precision iterative refinement failed to converge to a * satisfactory solution, so we resort to double precision. * - CALL ZGETRF(N,N,A,LDA,IPIV,INFO) + CALL ZGETRF( N, N, A, LDA, IPIV, INFO ) * - CALL ZLACPY('All',N,NRHS,B,LDB,X,LDX) + IF( INFO.NE.0 ) + + RETURN * - IF (INFO.EQ.0) THEN - CALL ZGETRS('No transpose',N,NRHS,A,LDA,IPIV,X,LDX,INFO) - END IF + CALL ZLACPY( 'All', N, NRHS, B, LDB, X, LDX ) + CALL ZGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, X, LDX, + + INFO ) * RETURN * diff --git a/SRC/zcposv.f b/SRC/zcposv.f new file mode 100644 index 00000000..daea32a0 --- /dev/null +++ b/SRC/zcposv.f @@ -0,0 +1,364 @@ + SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, + + SWORK, RWORK, ITER, INFO ) +* +* -- LAPACK PROTOTYPE driver routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. +* November 2008 +* +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX SWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( N, * ), + + X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* ZCPOSV computes the solution to a complex system of linear equations +* A * X = B, +* where A is an N-by-N Hermitian positive definite matrix and X and B +* are N-by-NRHS matrices. +* +* ZCPOSV first attempts to factorize the matrix in COMPLEX and use this +* factorization within an iterative refinement procedure to produce a +* solution with COMPLEX*16 normwise backward error quality (see below). +* If the approach fails the method switches to a COMPLEX*16 +* factorization and solve. +* +* The iterative refinement is not going to be a winning strategy if +* the ratio COMPLEX performance over COMPLEX*16 performance is too +* small. A reasonable strategy should take the number of right-hand +* sides and the size of the matrix into account. This might be done +* with a call to ILAENV in the future. Up to now, we always try +* iterative refinement. +* +* The iterative refinement process is stopped if +* ITER > ITERMAX +* or for all the RHS we have: +* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX +* where +* o ITER is the number of the current iteration in the iterative +* refinement process +* o RNRM is the infinity-norm of the residual +* o XNRM is the infinity-norm of the solution +* o ANRM is the infinity-operator-norm of the matrix A +* o EPS is the machine epsilon returned by DLAMCH('Epsilon') +* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 +* respectively. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input or input/ouptut) COMPLEX*16 array, +* dimension (LDA,N) +* On entry, the Hermitian matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* Note that the imaginary parts of the diagonal +* elements need not be set and are assumed to be zero. +* +* On exit, if iterative refinement has been successfully used +* (INFO.EQ.0 and ITER.GE.0, see description below), then A is +* unchanged, if double precision factorization has been used +* (INFO.EQ.0 and ITER.LT.0, see description below), then the +* array A contains the factor U or L from the Cholesky +* factorization A = U**H*U or A = L*L**H. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* B (input) COMPLEX*16 array, dimension (LDB,NRHS) +* The N-by-NRHS right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX*16 array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* WORK (workspace) COMPLEX*16 array, dimension (N*NRHS) +* This array is used to hold the residual vectors. +* +* SWORK (workspace) COMPLEX array, dimension (N*(N+NRHS)) +* This array is used to use the single precision matrix and the +* right-hand sides or solutions in single precision. +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* ITER (output) INTEGER +* < 0: iterative refinement has failed, COMPLEX*16 +* factorization has been performed +* -1 : the routine fell back to full precision for +* implementation- or machine-specific reasons +* -2 : narrowing the precision induced an overflow, +* the routine fell back to full precision +* -3 : failure of CPOTRF +* -31: stop the iterative refinement after the 30th +* iterations +* > 0: iterative refinement has been sucessfully used. +* Returns the number of iterations +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i of +* (COMPLEX*16) A is not positive definite, so the +* factorization could not be completed, and the solution +* has not been computed. +* +* ========= +* +* .. Parameters .. + LOGICAL DOITREF + PARAMETER ( DOITREF = .TRUE. ) +* + INTEGER ITERMAX + PARAMETER ( ITERMAX = 30 ) +* + DOUBLE PRECISION BWDMAX + PARAMETER ( BWDMAX = 1.0E+00 ) +* + COMPLEX*16 NEGONE, ONE + PARAMETER ( NEGONE = ( -1.0D+00, 0.0D+00 ), + + ONE = ( 1.0D+00, 0.0D+00 ) ) +* +* .. Local Scalars .. + INTEGER I, IITER, PTSA, PTSX + DOUBLE PRECISION ANRM, CTE, EPS, RNRM, XNRM + COMPLEX*16 ZDUM +* +* .. External Subroutines .. + EXTERNAL ZAXPY, ZHEMM, ZLACPY, ZLAT2C, ZLAG2C, CLAG2Z, + + CPOTRF, CPOTRS, XERBLA +* .. +* .. External Functions .. + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, ZLANHE + LOGICAL LSAME + EXTERNAL IZAMAX, DLAMCH, ZLANHE, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + INFO = 0 + ITER = 0 +* +* Test the input parameters. +* + IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZCPOSV', -INFO ) + RETURN + END IF +* +* Quick return if (N.EQ.0). +* + IF( N.EQ.0 ) + + RETURN +* +* Skip single precision iterative refinement if a priori slower +* than double precision factorization. +* + IF( .NOT.DOITREF ) THEN + ITER = -1 + GO TO 40 + END IF +* +* Compute some constants. +* + ANRM = ZLANHE( 'I', UPLO, N, A, LDA, WORK ) + EPS = DLAMCH( 'Epsilon' ) + CTE = ANRM*EPS*SQRT( DBLE( N ) )*BWDMAX +* +* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. +* + PTSA = 1 + PTSX = PTSA + N*N +* +* Convert B from double precision to single precision and store the +* result in SX. +* + CALL ZLAG2C( N, NRHS, B, LDB, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Convert A from double precision to single precision and store the +* result in SA. +* + CALL ZLAT2C( UPLO, N, A, LDA, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Compute the Cholesky factorization of SA. +* + CALL CPOTRF( UPLO, N, SWORK( PTSA ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -3 + GO TO 40 + END IF +* +* Solve the system SA*SX = SB. +* + CALL CPOTRS( UPLO, N, NRHS, SWORK( PTSA ), N, SWORK( PTSX ), N, + + INFO ) +* +* Convert SX back to COMPLEX*16 +* + CALL CLAG2Z( N, NRHS, SWORK( PTSX ), N, X, LDX, INFO ) +* +* Compute R = B - AX (R is WORK). +* + CALL ZLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL ZHEMM( 'Left', UPLO, N, NRHS, NEGONE, A, LDA, X, LDX, ONE, + + WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=0 and return. +* + DO I = 1, NRHS + XNRM = CABS1( X( IZAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = CABS1( WORK( IZAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 10 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion. We are good to exit. +* + ITER = 0 + RETURN +* + 10 CONTINUE +* + DO 30 IITER = 1, ITERMAX +* +* Convert R (in WORK) from double precision to single precision +* and store the result in SX. +* + CALL ZLAG2C( N, NRHS, WORK, N, SWORK( PTSX ), N, INFO ) +* + IF( INFO.NE.0 ) THEN + ITER = -2 + GO TO 40 + END IF +* +* Solve the system SA*SX = SR. +* + CALL CPOTRS( UPLO, N, NRHS, SWORK( PTSA ), N, SWORK( PTSX ), N, + + INFO ) +* +* Convert SX back to double precision and update the current +* iterate. +* + CALL CLAG2Z( N, NRHS, SWORK( PTSX ), N, WORK, N, INFO ) +* + DO I = 1, NRHS + CALL ZAXPY( N, ONE, WORK( 1, I ), 1, X( 1, I ), 1 ) + END DO +* +* Compute R = B - AX (R is WORK). +* + CALL ZLACPY( 'All', N, NRHS, B, LDB, WORK, N ) +* + CALL ZHEMM( 'L', UPLO, N, NRHS, NEGONE, A, LDA, X, LDX, ONE, + + WORK, N ) +* +* Check whether the NRHS normwise backward errors satisfy the +* stopping criterion. If yes, set ITER=IITER>0 and return. +* + DO I = 1, NRHS + XNRM = CABS1( X( IZAMAX( N, X( 1, I ), 1 ), I ) ) + RNRM = CABS1( WORK( IZAMAX( N, WORK( 1, I ), 1 ), I ) ) + IF( RNRM.GT.XNRM*CTE ) + + GO TO 20 + END DO +* +* If we are here, the NRHS normwise backward errors satisfy the +* stopping criterion, we are good to exit. +* + ITER = IITER +* + RETURN +* + 20 CONTINUE +* + 30 CONTINUE +* +* If we are at this place of the code, this is because we have +* performed ITER=ITERMAX iterations and never satisified the +* stopping criterion, set up the ITER flag accordingly and follow +* up on double precision routine. +* + ITER = -ITERMAX - 1 +* + 40 CONTINUE +* +* Single-precision iterative refinement failed to converge to a +* satisfactory solution, so we resort to double precision. +* + CALL ZPOTRF( UPLO, N, A, LDA, INFO ) +* + IF( INFO.NE.0 ) + + RETURN +* + CALL ZLACPY( 'All', N, NRHS, B, LDB, X, LDX ) + CALL ZPOTRS( UPLO, N, NRHS, A, LDA, X, LDX, INFO ) +* + RETURN +* +* End of ZCPOSV. +* + END diff --git a/SRC/zdrscl.f b/SRC/zdrscl.f index 11686d0b..dc6faae2 100644 --- a/SRC/zdrscl.f +++ b/SRC/zdrscl.f @@ -1,6 +1,6 @@ SUBROUTINE ZDRSCL( N, SA, SX, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbbrd.f b/SRC/zgbbrd.f index 55fcb282..8a216850 100644 --- a/SRC/zgbbrd.f +++ b/SRC/zgbbrd.f @@ -1,7 +1,7 @@ SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, $ LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbcon.f b/SRC/zgbcon.f index b99cfe29..e6c64605 100644 --- a/SRC/zgbcon.f +++ b/SRC/zgbcon.f @@ -1,7 +1,7 @@ SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, $ WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbequ.f b/SRC/zgbequ.f index cb674acc..9db47bb6 100644 --- a/SRC/zgbequ.f +++ b/SRC/zgbequ.f @@ -1,7 +1,7 @@ SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbequb.f b/SRC/zgbequb.f new file mode 100644 index 00000000..8bcecbc7 --- /dev/null +++ b/SRC/zgbequb.f @@ -0,0 +1,270 @@ + SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( * ), R( * ) + COMPLEX*16 AB( LDAB, * ) +* .. +* +* Purpose +* ======= +* +* ZGBEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from ZGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* LDAB (input) INTEGER +* The leading dimension of the array A. LDAB >= max(1,M). +* +* R (output) DOUBLE PRECISION array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) DOUBLE PRECISION +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) DOUBLE PRECISION +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, + $ LOGRDX + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( KL.LT.0 ) THEN + INFO = -3 + ELSE IF( KU.LT.0 ) THEN + INFO = -4 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGBEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = DLAMCH( 'B' ) + LOGRDX = LOG(RADIX) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + KD = KU + 1 + DO 30 J = 1, N + DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + R( I ) = MAX( R( I ), CABS1( AB( KD+I-J, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG( R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) + C( J ) = MAX( C( J ), CABS1( AB( KD+I-J, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of ZGBEQUB +* + END diff --git a/SRC/zgbrfs.f b/SRC/zgbrfs.f index 045b6a25..f916da70 100644 --- a/SRC/zgbrfs.f +++ b/SRC/zgbrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbrfsx.f b/SRC/zgbrfsx.f new file mode 100644 index 00000000..d756afaa --- /dev/null +++ b/SRC/zgbrfsx.f @@ -0,0 +1,624 @@ + SUBROUTINE ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, + $ NPARAMS, N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGBRFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) +* The original band matrix A, stored in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) +* Details of the LU factorization of the band matrix A, as +* computed by DGBTRF. U is stored as an upper triangular band +* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and +* the multipliers used during the factorization are stored in +* rows KL+KU+2 to 2*KL+KU+1. +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 100.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN, IGNORE_CWISE + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE, N_NORMS, + $ ITHRESH + DOUBLE PRECISION ANORM, RCOND_TMP, ILLRCOND_THRESH, ERR_LBND, + $ CWISE_WRONG, RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGBCON, ZLA_GBRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, ZLANGB, ZLA_GBRCOND_X, ZLA_GBRCOND_C + DOUBLE PRECISION DLAMCH, ZLANGB, ZLA_GBRCOND_X, ZLA_GBRCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGBRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = ZLANGB( NORM, N, KL, KU, AB, LDAB, WORK ) + CALL ZGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND, + $ WORK, RWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + IF ( NOTRAN ) THEN + CALL ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + ELSE + CALL ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, C, .TRUE., INFO, WORK, RWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, R, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, LDAB, AFB, + $ LDAFB, IPIV, C, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, LDAB, + $ AFB, LDAFB, IPIV, X( 1, J ), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of ZGBRFSX +* + END diff --git a/SRC/zgbsv.f b/SRC/zgbsv.f index 92db215c..6ca78af9 100644 --- a/SRC/zgbsv.f +++ b/SRC/zgbsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbsvx.f b/SRC/zgbsvx.f index bb8e8163..7b586859 100644 --- a/SRC/zgbsvx.f +++ b/SRC/zgbsvx.f @@ -2,7 +2,7 @@ $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbsvxx.f b/SRC/zgbsvxx.f new file mode 100644 index 00000000..f5229c92 --- /dev/null +++ b/SRC/zgbsvxx.f @@ -0,0 +1,655 @@ + SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, + $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, + $ RCOND, RPVGRW, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGBSVXX uses the LU factorization to compute the solution to a +* complex*16 system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. ZGBSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* ZGBSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* ZGBSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what ZGBSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose = Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* KL (input) INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU (input) INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) +* On entry, the matrix A in band storage, in rows 1 to KL+KU+1. +* The j-th column of A is stored in the j-th column of the +* array AB as follows: +* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) +* +* If FACT = 'F' and EQUED is not 'N', then AB must have been +* equilibrated by the scaling factors in R and/or C. AB is not +* modified if FACT = 'F' or 'N', or if FACT = 'E' and +* EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDAB (input) INTEGER +* The leading dimension of the array AB. LDAB >= KL+KU+1. +* +* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N) +* If FACT = 'F', then AFB is an input argument and on entry +* contains details of the LU factorization of the band matrix +* A, as computed by ZGBTRF. U is stored as an upper triangular +* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, +* and the multipliers used during the factorization are stored +* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is +* the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAFB (input) INTEGER +* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by DGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In DGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, I, J, KL, KU + DOUBLE PRECISION AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, ZLA_GBRPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ZGBEQUB, ZGBTRF, ZGBTRS, ZLACPY, ZLAQGB, + $ XERBLA, ZLASCL2, ZGBRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in ZGBRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until DGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( KL.LT.0 ) THEN + INFO = -4 + ELSE IF( KU.LT.0 ) THEN + INFO = -5 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -6 + ELSE IF( LDAB.LT.KL+KU+1 ) THEN + INFO = -8 + ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN + INFO = -10 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -12 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -13 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -14 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -15 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGBSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL ZGBEQUB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL ZLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, + $ AMAX, EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0D+0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0D+0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL ZLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL ZLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + DO 40, J = 1, N + DO 30, I = KL+1, 2*KL+KU+1 + AFB( I, J ) = AB( I-KL, J ) + 30 CONTINUE + 40 CONTINUE + CALL ZGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = ZLA_GBRPVGRW( N, KL, KU, INFO, AB, LDAB, AFB, + $ LDAFB ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = ZLA_GBRPVGRW( N, KL, KU, N, AB, LDAB, AFB, LDAFB ) +* +* Compute the solution matrix X. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL ZGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX, + $ INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL ZGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) + +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL ZLASCL2( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL ZLASCL2( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of ZGBSVXX +* + END diff --git a/SRC/zgbtf2.f b/SRC/zgbtf2.f index e722d54e..5762e610 100644 --- a/SRC/zgbtf2.f +++ b/SRC/zgbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbtrf.f b/SRC/zgbtrf.f index 3d6f21ad..2bebc288 100644 --- a/SRC/zgbtrf.f +++ b/SRC/zgbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgbtrs.f b/SRC/zgbtrs.f index bd61a861..a5cfb18f 100644 --- a/SRC/zgbtrs.f +++ b/SRC/zgbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgebak.f b/SRC/zgebak.f index 1023601d..75aa9d47 100644 --- a/SRC/zgebak.f +++ b/SRC/zgebak.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgebal.f b/SRC/zgebal.f index 67ac2e14..ae1f0e7b 100644 --- a/SRC/zgebal.f +++ b/SRC/zgebal.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgebd2.f b/SRC/zgebd2.f index 5ba52e87..457e8c39 100644 --- a/SRC/zgebd2.f +++ b/SRC/zgebd2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgebrd.f b/SRC/zgebrd.f index 4f97bd7e..ef05537b 100644 --- a/SRC/zgebrd.f +++ b/SRC/zgebrd.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgecon.f b/SRC/zgecon.f index cfaaca35..1415b71f 100644 --- a/SRC/zgecon.f +++ b/SRC/zgecon.f @@ -1,7 +1,7 @@ SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeequ.f b/SRC/zgeequ.f index 04609ee2..727ce450 100644 --- a/SRC/zgeequ.f +++ b/SRC/zgeequ.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeequb.f b/SRC/zgeequb.f new file mode 100644 index 00000000..a2931c6a --- /dev/null +++ b/SRC/zgeequb.f @@ -0,0 +1,256 @@ + SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N + DOUBLE PRECISION AMAX, COLCND, ROWCND +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( * ), R( * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZGEEQUB computes row and column scalings intended to equilibrate an +* M-by-N matrix A and reduce its condition number. R returns the row +* scale factors and C the column scale factors, chosen to try to make +* the largest element in each row and column of the matrix B with +* elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most +* the radix. +* +* R(i) and C(j) are restricted to be a power of the radix between +* SMLNUM = smallest safe number and BIGNUM = largest safe number. Use +* of these scaling factors is not guaranteed to reduce the condition +* number of A but works well in practice. +* +* This routine differs from ZGEEQU by restricting the scaling factors +* to a power of the radix. Baring over- and underflow, scaling by +* these factors introduces no additional rounding errors. However, the +* scaled entries' magnitured are no longer approximately 1 but lie +* between sqrt(radix) and 1/sqrt(radix). +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The M-by-N matrix whose equilibration factors are +* to be computed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* R (output) DOUBLE PRECISION array, dimension (M) +* If INFO = 0 or INFO > M, R contains the row scale factors +* for A. +* +* C (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, C contains the column scale factors for A. +* +* ROWCND (output) DOUBLE PRECISION +* If INFO = 0 or INFO > M, ROWCND contains the ratio of the +* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and +* AMAX is neither too large nor too small, it is not worth +* scaling by R. +* +* COLCND (output) DOUBLE PRECISION +* If INFO = 0, COLCND contains the ratio of the smallest +* C(i) to the largest C(i). If COLCND >= 0.1, it is not +* worth scaling by C. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, and i is +* <= M: the i-th row of A is exactly zero +* > M: the (i-M)-th column of A is exactly zero +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM, RADIX, LOGRDX + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, LOG, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN + ROWCND = ONE + COLCND = ONE + AMAX = ZERO + RETURN + END IF +* +* Get machine constants. Assume SMLNUM is a power of the radix. +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM + RADIX = DLAMCH( 'B' ) + LOGRDX = LOG( RADIX ) +* +* Compute row scale factors. +* + DO 10 I = 1, M + R( I ) = ZERO + 10 CONTINUE +* +* Find the maximum element in each row. +* + DO 30 J = 1, N + DO 20 I = 1, M + R( I ) = MAX( R( I ), CABS1( A( I, J ) ) ) + 20 CONTINUE + 30 CONTINUE + DO I = 1, M + IF( R( I ).GT.ZERO ) THEN + R( I ) = RADIX**INT( LOG(R( I ) ) / LOGRDX ) + END IF + END DO +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 40 I = 1, M + RCMAX = MAX( RCMAX, R( I ) ) + RCMIN = MIN( RCMIN, R( I ) ) + 40 CONTINUE + AMAX = RCMAX +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 50 I = 1, M + IF( R( I ).EQ.ZERO ) THEN + INFO = I + RETURN + END IF + 50 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 60 I = 1, M + R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) + 60 CONTINUE +* +* Compute ROWCND = min(R(I)) / max(R(I)). +* + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* +* Compute column scale factors. +* + DO 70 J = 1, N + C( J ) = ZERO + 70 CONTINUE +* +* Find the maximum element in each column, +* assuming the row scaling computed above. +* + DO 90 J = 1, N + DO 80 I = 1, M + C( J ) = MAX( C( J ), CABS1( A( I, J ) )*R( I ) ) + 80 CONTINUE + IF( C( J ).GT.ZERO ) THEN + C( J ) = RADIX**INT( LOG( C( J ) ) / LOGRDX ) + END IF + 90 CONTINUE +* +* Find the maximum and minimum scale factors. +* + RCMIN = BIGNUM + RCMAX = ZERO + DO 100 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 100 CONTINUE +* + IF( RCMIN.EQ.ZERO ) THEN +* +* Find the first zero scale factor and return an error code. +* + DO 110 J = 1, N + IF( C( J ).EQ.ZERO ) THEN + INFO = M + J + RETURN + END IF + 110 CONTINUE + ELSE +* +* Invert the scale factors. +* + DO 120 J = 1, N + C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) + 120 CONTINUE +* +* Compute COLCND = min(C(J)) / max(C(J)). +* + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + END IF +* + RETURN +* +* End of ZGEEQUB +* + END diff --git a/SRC/zgees.f b/SRC/zgees.f index ade5f9f2..b9b94e3b 100644 --- a/SRC/zgees.f +++ b/SRC/zgees.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, $ LDVS, WORK, LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeesx.f b/SRC/zgeesx.f index b7567c30..3c643b61 100644 --- a/SRC/zgeesx.f +++ b/SRC/zgeesx.f @@ -2,7 +2,7 @@ $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, $ BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeev.f b/SRC/zgeev.f index 0fa66307..da33f8ab 100644 --- a/SRC/zgeev.f +++ b/SRC/zgeev.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeevx.f b/SRC/zgeevx.f index a4473c48..9e9d70b1 100644 --- a/SRC/zgeevx.f +++ b/SRC/zgeevx.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, $ RCONDV, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgegs.f b/SRC/zgegs.f index c6b30c73..1de40fba 100644 --- a/SRC/zgegs.f +++ b/SRC/zgegs.f @@ -2,7 +2,7 @@ $ VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgegv.f b/SRC/zgegv.f index fdc3bded..90552dab 100644 --- a/SRC/zgegv.f +++ b/SRC/zgegv.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgehd2.f b/SRC/zgehd2.f index c73f4200..f5fbbdf1 100644 --- a/SRC/zgehd2.f +++ b/SRC/zgehd2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgehrd.f b/SRC/zgehrd.f index 83c1aa32..045feaee 100644 --- a/SRC/zgehrd.f +++ b/SRC/zgehrd.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgelq2.f b/SRC/zgelq2.f index 4c2368aa..34008f9e 100644 --- a/SRC/zgelq2.f +++ b/SRC/zgelq2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgelqf.f b/SRC/zgelqf.f index 5dac50dc..50fda2fb 100644 --- a/SRC/zgelqf.f +++ b/SRC/zgelqf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgels.f b/SRC/zgels.f index 96ff913e..b3eda37e 100644 --- a/SRC/zgels.f +++ b/SRC/zgels.f @@ -1,7 +1,7 @@ SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgelsd.f b/SRC/zgelsd.f index e6d785e8..86ae7553 100644 --- a/SRC/zgelsd.f +++ b/SRC/zgelsd.f @@ -1,7 +1,7 @@ SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgelss.f b/SRC/zgelss.f index 7ea253ad..f4acd16b 100644 --- a/SRC/zgelss.f +++ b/SRC/zgelss.f @@ -1,7 +1,7 @@ SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgelsx.f b/SRC/zgelsx.f index d4d9130c..11f465c8 100644 --- a/SRC/zgelsx.f +++ b/SRC/zgelsx.f @@ -1,7 +1,7 @@ SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgelsy.f b/SRC/zgelsy.f index 684cf2c2..7a196956 100644 --- a/SRC/zgelsy.f +++ b/SRC/zgelsy.f @@ -1,7 +1,7 @@ SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeql2.f b/SRC/zgeql2.f index 33035883..0542f4e5 100644 --- a/SRC/zgeql2.f +++ b/SRC/zgeql2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeqlf.f b/SRC/zgeqlf.f index d28bdc67..765ca8b3 100644 --- a/SRC/zgeqlf.f +++ b/SRC/zgeqlf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeqp3.f b/SRC/zgeqp3.f index 32bf3367..aad21e51 100644 --- a/SRC/zgeqp3.f +++ b/SRC/zgeqp3.f @@ -1,7 +1,7 @@ SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeqpf.f b/SRC/zgeqpf.f index 19b4966c..e551c0a7 100644 --- a/SRC/zgeqpf.f +++ b/SRC/zgeqpf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEQPF( M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO ) * -* -- LAPACK deprecated driver routine (version 3.1) -- +* -- LAPACK deprecated driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeqr2.f b/SRC/zgeqr2.f index 215eab79..6149187c 100644 --- a/SRC/zgeqr2.f +++ b/SRC/zgeqr2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgeqrf.f b/SRC/zgeqrf.f index d11c9245..4b2a71e7 100644 --- a/SRC/zgeqrf.f +++ b/SRC/zgeqrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgerfs.f b/SRC/zgerfs.f index 8b85fe65..cc1e24de 100644 --- a/SRC/zgerfs.f +++ b/SRC/zgerfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgerfsx.f b/SRC/zgerfsx.f new file mode 100644 index 00000000..edb1bcae --- /dev/null +++ b/SRC/zgerfsx.f @@ -0,0 +1,606 @@ + SUBROUTINE ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ), WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGERFSX improves the computed solution to a system of linear +* equations and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS_N and ERR_BNDS_C for details of the error +* bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED, R +* and C below. In this case, the solution and error bounds returned +* are for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate transpose = Transpose) +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The original N-by-N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX*16 array, dimension (LDAF,N) +* The factors L and U from the factorization A = P*L*U +* as computed by ZGETRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from ZGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input) COMPLEX*16 array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by ZGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL ROWEQU, COLEQU, NOTRAN + INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGECON, ZLA_GERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, ZLANGE, ZLA_GERCOND_X, ZLA_GERCOND_C + DOUBLE PRECISION DLAMCH, ZLANGE, ZLA_GERCOND_X, ZLA_GERCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + TRANS_TYPE = ILATRANS( TRANS ) + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS(LA_LINRX_ITHRESH_I) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + NOTRAN = LSAME( TRANS, 'N' ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) +* +* Test input parameters. +* + IF( TRANS_TYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( .NOT.ROWEQU .AND. .NOT.COLEQU .AND. + $ .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -13 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -15 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + IF( NOTRAN ) THEN + NORM = 'I' + ELSE + NORM = '1' + END IF + ANORM = ZLANGE( NORM, N, N, A, LDA, WORK ) + CALL ZGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + IF ( NOTRAN ) THEN + CALL ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + ELSE + CALL ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, ROWEQU, C, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, WORK(N+1), RWORK, WORK(1), RWORK, RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( COLEQU .AND. NOTRAN ) THEN + RCOND_TMP = ZLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ C, .TRUE., INFO, WORK, RWORK ) + ELSE IF ( ROWEQU .AND. .NOT. NOTRAN ) THEN + RCOND_TMP = ZLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ R, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = ZLA_GERCOND_C( TRANS, N, A, LDA, AF, LDAF, IPIV, + $ C, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF (ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = ZLA_GERCOND_X( TRANS, N, A, LDA, AF, LDAF, + $ IPIV, X(1,J), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of ZGERFSX +* + END diff --git a/SRC/zgerq2.f b/SRC/zgerq2.f index 4d69c240..892a58da 100644 --- a/SRC/zgerq2.f +++ b/SRC/zgerq2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgerqf.f b/SRC/zgerqf.f index 4e249f1e..5ad149bd 100644 --- a/SRC/zgerqf.f +++ b/SRC/zgerqf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgesc2.f b/SRC/zgesc2.f index d4d51337..34a9ca44 100644 --- a/SRC/zgesc2.f +++ b/SRC/zgesc2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgesdd.f b/SRC/zgesdd.f index f717080f..7bc6d8af 100644 --- a/SRC/zgesdd.f +++ b/SRC/zgesdd.f @@ -1,7 +1,7 @@ SUBROUTINE ZGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, $ LWORK, RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * 8-15-00: Improve consistency of WS calculations (eca) diff --git a/SRC/zgesv.f b/SRC/zgesv.f index b5f61f82..d04e21f5 100644 --- a/SRC/zgesv.f +++ b/SRC/zgesv.f @@ -1,6 +1,6 @@ SUBROUTINE ZGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgesvd.f b/SRC/zgesvd.f index 7b238d8b..e969d60f 100644 --- a/SRC/zgesvd.f +++ b/SRC/zgesvd.f @@ -1,7 +1,7 @@ SUBROUTINE ZGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, $ WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgesvx.f b/SRC/zgesvx.f index 8c715d44..d4ca0575 100644 --- a/SRC/zgesvx.f +++ b/SRC/zgesvx.f @@ -2,7 +2,7 @@ $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgesvxx.f b/SRC/zgesvxx.f new file mode 100644 index 00000000..b6b4b95d --- /dev/null +++ b/SRC/zgesvxx.f @@ -0,0 +1,630 @@ + SUBROUTINE ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, R, C, B, LDB, X, LDX, RCOND, RPVGRW, + $ BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, + $ INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, TRANS + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX , * ),WORK( * ) + DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* ZGESVXX uses the LU factorization to compute the solution to a +* complex*16 system of linear equations A * X = B, where A is an +* N-by-N matrix and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. ZGESVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* ZGESVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* ZGESVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what ZGESVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B +* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B +* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') +* or diag(C)*B (if TRANS = 'T' or 'C'). +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = P * L * U, +* +* where P is a permutation matrix, L is a unit lower triangular +* matrix, and U is upper triangular. +* +* 3. If some U(i,i)=0, so that U is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is less +* than machine precision, the routine still goes on to solve for X +* and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so +* that it solves the original system before equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by R and C. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A**T * X = B (Transpose) +* = 'C': A**H * X = B (Conjugate Transpose) +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is +* not 'N', then A must have been equilibrated by the scaling +* factors in R and/or C. A is not modified if FACT = 'F' or +* 'N', or if FACT = 'E' and EQUED = 'N' on exit. +* +* On exit, if EQUED .ne. 'N', A is scaled as follows: +* EQUED = 'R': A := diag(R) * A +* EQUED = 'C': A := A * diag(C) +* EQUED = 'B': A := diag(R) * A * diag(C). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the factors L and U from the factorization +* A = P*L*U as computed by ZGETRF. If EQUED .ne. 'N', then +* AF is the factored form of the equilibrated matrix A. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the factors L and U from the factorization A = P*L*U +* of the equilibrated matrix A (see the description of A for +* the form of the equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains the pivot indices from the factorization A = P*L*U +* as computed by ZGETRF; row i of the matrix was interchanged +* with row IPIV(i). +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the original matrix A. +* +* If FACT = 'E', then IPIV is an output argument and on exit +* contains the pivot indices from the factorization A = P*L*U +* of the equilibrated matrix A. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'R': Row equilibration, i.e., A has been premultiplied by +* diag(R). +* = 'C': Column equilibration, i.e., A has been postmultiplied +* by diag(C). +* = 'B': Both row and column equilibration, i.e., A has been +* replaced by diag(R) * A * diag(C). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* R (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'R' or 'B', A is +* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R +* is not accessed. R is an input argument if FACT = 'F'; +* otherwise, R is an output argument. If FACT = 'F' and +* EQUED = 'R' or 'B', each element of R must be positive. +* If R is output, each element of R is a power of the radix. +* If R is input, each element of R should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* C (input or output) DOUBLE PRECISION array, dimension (N) +* The column scale factors for A. If EQUED = 'C' or 'B', A is +* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C +* is not accessed. C is an input argument if FACT = 'F'; +* otherwise, C is an output argument. If FACT = 'F' and +* EQUED = 'C' or 'B', each element of C must be positive. +* If C is output, each element of C is a power of the radix. +* If C is input, each element of C should be a power of the radix +* to ensure a reliable solution and error estimates. Scaling by +* powers of the radix does not cause rounding errors unless the +* result underflows or overflows. Rounding errors during scaling +* lead to refining with a matrix that is not equivalent to the +* input matrix, producing error estimates that may not be +* reliable. +* +* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by +* diag(R)*B; +* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is +* overwritten by diag(C)*B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX*16 array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit +* if EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or +* inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. In ZGESVX, this quantity is +* returned in WORK(1). +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) COMPLEX*16 array, dimension (2*N) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, COLCND, RCMAX, RCMIN, + $ ROWCND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, ZLA_RPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ZGEEQUB, ZGETRF, ZGETRS, ZLACPY, ZLAQGE, + $ XERBLA, ZLASCL2, ZGERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + NOTRAN = LSAME( TRANS, 'N' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + ROWEQU = .FALSE. + COLEQU = .FALSE. + ELSE + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in ZGERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until ZGERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -10 + ELSE + IF( ROWEQU ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 10 J = 1, N + RCMIN = MIN( RCMIN, R( J ) ) + RCMAX = MAX( RCMAX, R( J ) ) + 10 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -11 + ELSE IF( N.GT.0 ) THEN + ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + ROWCND = ONE + END IF + END IF + IF( COLEQU .AND. INFO.EQ.0 ) THEN + RCMIN = BIGNUM + RCMAX = ZERO + DO 20 J = 1, N + RCMIN = MIN( RCMIN, C( J ) ) + RCMAX = MAX( RCMAX, C( J ) ) + 20 CONTINUE + IF( RCMIN.LE.ZERO ) THEN + INFO = -12 + ELSE IF( N.GT.0 ) THEN + COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) + ELSE + COLCND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -14 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -16 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL ZGEEQUB( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL ZLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, + $ EQUED ) + ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' ) + COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' ) + END IF +* +* If the scaling factors are not applied, set them to 1.0. +* + IF ( .NOT.ROWEQU ) THEN + DO J = 1, N + R( J ) = 1.0D+0 + END DO + END IF + IF ( .NOT.COLEQU ) THEN + DO J = 1, N + C( J ) = 1.0D+0 + END DO + END IF + END IF +* +* Scale the right-hand side. +* + IF( NOTRAN ) THEN + IF( ROWEQU ) CALL ZLASCL2( N, NRHS, R, B, LDB ) + ELSE + IF( COLEQU ) CALL ZLASCL2( N, NRHS, C, B, LDB ) + END IF +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL ZLACPY( 'Full', N, N, A, LDA, AF, LDAF ) + CALL ZGETRF( N, N, AF, LDAF, IPIV, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = ZLA_RPVGRW( N, INFO, A, LDA, AF, LDAF ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = ZLA_RPVGRW( N, N, A, LDA, AF, LDAF ) +* +* Compute the solution matrix X. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL ZGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL ZGERFSX( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* Scale solutions. +* + IF ( COLEQU .AND. NOTRAN ) THEN + CALL ZLASCL2 ( N, NRHS, C, X, LDX ) + ELSE IF ( ROWEQU .AND. .NOT.NOTRAN ) THEN + CALL ZLASCL2 ( N, NRHS, R, X, LDX ) + END IF +* + RETURN +* +* End of ZGESVXX +* + END diff --git a/SRC/zgetc2.f b/SRC/zgetc2.f index 35ac376c..d84e28d8 100644 --- a/SRC/zgetc2.f +++ b/SRC/zgetc2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETC2( N, A, LDA, IPIV, JPIV, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgetf2.f b/SRC/zgetf2.f index a2dc1834..6cec496e 100644 --- a/SRC/zgetf2.f +++ b/SRC/zgetf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgetrf.f b/SRC/zgetrf.f index 9c7bfbbf..e8d06c75 100644 --- a/SRC/zgetrf.f +++ b/SRC/zgetrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgetri.f b/SRC/zgetri.f index 685518e6..0c130b28 100644 --- a/SRC/zgetri.f +++ b/SRC/zgetri.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgetrs.f b/SRC/zgetrs.f index e32549cd..91398c6f 100644 --- a/SRC/zgetrs.f +++ b/SRC/zgetrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggbak.f b/SRC/zggbak.f index ad6dd032..69ef2930 100644 --- a/SRC/zggbak.f +++ b/SRC/zggbak.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, $ LDV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggbal.f b/SRC/zggbal.f index b75ae456..42a0e100 100644 --- a/SRC/zggbal.f +++ b/SRC/zggbal.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, $ RSCALE, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgges.f b/SRC/zgges.f index c1499003..3c5fd717 100644 --- a/SRC/zgges.f +++ b/SRC/zgges.f @@ -2,7 +2,7 @@ $ SDIM, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, $ LWORK, RWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggesx.f b/SRC/zggesx.f index 84c1a183..13f980be 100644 --- a/SRC/zggesx.f +++ b/SRC/zggesx.f @@ -3,7 +3,7 @@ $ LDVSR, RCONDE, RCONDV, WORK, LWORK, RWORK, $ IWORK, LIWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggev.f b/SRC/zggev.f index 94fb3dc2..ae32b3bd 100644 --- a/SRC/zggev.f +++ b/SRC/zggev.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHA, BETA, $ VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggevx.f b/SRC/zggevx.f index b12e513a..16469351 100644 --- a/SRC/zggevx.f +++ b/SRC/zggevx.f @@ -3,7 +3,7 @@ $ LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV, $ WORK, LWORK, RWORK, IWORK, BWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggglm.f b/SRC/zggglm.f index 4b18107a..5f3b03f4 100644 --- a/SRC/zggglm.f +++ b/SRC/zggglm.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgghrd.f b/SRC/zgghrd.f index 652c09d7..fa29e730 100644 --- a/SRC/zgghrd.f +++ b/SRC/zgghrd.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, $ LDQ, Z, LDZ, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgglse.f b/SRC/zgglse.f index 9a549237..0438218c 100644 --- a/SRC/zgglse.f +++ b/SRC/zgglse.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * February 2007 * diff --git a/SRC/zggqrf.f b/SRC/zggqrf.f index 93b66cdf..fd55e622 100644 --- a/SRC/zggqrf.f +++ b/SRC/zggqrf.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggrqf.f b/SRC/zggrqf.f index 351fe7a1..3cbc1d79 100644 --- a/SRC/zggrqf.f +++ b/SRC/zggrqf.f @@ -1,7 +1,7 @@ SUBROUTINE ZGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK, $ LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggsvd.f b/SRC/zggsvd.f index 8f085c90..916af6a3 100644 --- a/SRC/zggsvd.f +++ b/SRC/zggsvd.f @@ -2,7 +2,7 @@ $ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, $ RWORK, IWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zggsvp.f b/SRC/zggsvp.f index 1f61b7ff..4dba1bc4 100644 --- a/SRC/zggsvp.f +++ b/SRC/zggsvp.f @@ -2,7 +2,7 @@ $ TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, $ IWORK, RWORK, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -110,7 +110,7 @@ * The leading dimension of the array U. LDU >= max(1,M) if * JOBU = 'U'; LDU >= 1 otherwise. * -* V (output) COMPLEX*16 array, dimension (LDV,M) +* V (output) COMPLEX*16 array, dimension (LDV,P) * If JOBV = 'V', V contains the unitary matrix V. * If JOBV = 'N', V is not referenced. * diff --git a/SRC/zgtcon.f b/SRC/zgtcon.f index 43a3a873..97532fe2 100644 --- a/SRC/zgtcon.f +++ b/SRC/zgtcon.f @@ -1,7 +1,7 @@ SUBROUTINE ZGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgtrfs.f b/SRC/zgtrfs.f index 0eaa02a7..0dbd14e5 100644 --- a/SRC/zgtrfs.f +++ b/SRC/zgtrfs.f @@ -2,7 +2,7 @@ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgtsv.f b/SRC/zgtsv.f index ea466b38..c97bc7a3 100644 --- a/SRC/zgtsv.f +++ b/SRC/zgtsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgtsvx.f b/SRC/zgtsvx.f index 6ecebb07..ceb4bc94 100644 --- a/SRC/zgtsvx.f +++ b/SRC/zgtsvx.f @@ -2,7 +2,7 @@ $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgttrf.f b/SRC/zgttrf.f index 2d2c1aa6..24c9b0d7 100644 --- a/SRC/zgttrf.f +++ b/SRC/zgttrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZGTTRF( N, DL, D, DU, DU2, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgttrs.f b/SRC/zgttrs.f index 60e71f54..d07e59a6 100644 --- a/SRC/zgttrs.f +++ b/SRC/zgttrs.f @@ -1,7 +1,7 @@ SUBROUTINE ZGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zgtts2.f b/SRC/zgtts2.f index da6073d8..264b4bc5 100644 --- a/SRC/zgtts2.f +++ b/SRC/zgtts2.f @@ -1,6 +1,6 @@ SUBROUTINE ZGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbev.f b/SRC/zhbev.f index 6bfa26c9..ddaa73e3 100644 --- a/SRC/zhbev.f +++ b/SRC/zhbev.f @@ -1,7 +1,7 @@ SUBROUTINE ZHBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbevd.f b/SRC/zhbevd.f index a3b2ffe7..d4b59481 100644 --- a/SRC/zhbevd.f +++ b/SRC/zhbevd.f @@ -1,7 +1,7 @@ SUBROUTINE ZHBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbevx.f b/SRC/zhbevx.f index 78f31661..a68b3cb9 100644 --- a/SRC/zhbevx.f +++ b/SRC/zhbevx.f @@ -2,7 +2,7 @@ $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbgst.f b/SRC/zhbgst.f index 69685792..8e9793d0 100644 --- a/SRC/zhbgst.f +++ b/SRC/zhbgst.f @@ -1,7 +1,7 @@ SUBROUTINE ZHBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X, $ LDX, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbgv.f b/SRC/zhbgv.f index 534415d0..124fc907 100644 --- a/SRC/zhbgv.f +++ b/SRC/zhbgv.f @@ -1,7 +1,7 @@ SUBROUTINE ZHBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z, $ LDZ, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbgvd.f b/SRC/zhbgvd.f index 9c2d217d..75b66bc5 100644 --- a/SRC/zhbgvd.f +++ b/SRC/zhbgvd.f @@ -2,7 +2,7 @@ $ Z, LDZ, WORK, LWORK, RWORK, LRWORK, IWORK, $ LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbgvx.f b/SRC/zhbgvx.f index 28258d90..8a96a79b 100644 --- a/SRC/zhbgvx.f +++ b/SRC/zhbgvx.f @@ -2,7 +2,7 @@ $ LDBB, Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhbtrd.f b/SRC/zhbtrd.f index 40b643cb..94acc5bf 100644 --- a/SRC/zhbtrd.f +++ b/SRC/zhbtrd.f @@ -1,7 +1,7 @@ SUBROUTINE ZHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhecon.f b/SRC/zhecon.f index d5f72e89..d7e9403c 100644 --- a/SRC/zhecon.f +++ b/SRC/zhecon.f @@ -1,7 +1,7 @@ SUBROUTINE ZHECON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zheequb.f b/SRC/zheequb.f new file mode 100644 index 00000000..b276006f --- /dev/null +++ b/SRC/zheequb.f @@ -0,0 +1,255 @@ + SUBROUTINE ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), WORK( * ) + DOUBLE PRECISION S( * ) +* .. +* +* Purpose +* ======= +* +* ZSYEQUB computes row and column scalings intended to equilibrate a +* symmetric matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The N-by-N symmetric matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) DOUBLE PRECISION +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, + $ BASE, SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* +* Test input parameters. +* + INFO = 0 + IF (.NOT. ( LSAME( UPLO, 'U' ) .OR. 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( 'ZHEEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) + END DO + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A(I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0D+0 / S( J ) + END DO + + TOL = ONE / SQRT( 2.0D0 * N ) + + DO ITER = 1, MAX_ITER + SCALE = 0.0D+0 + SUMSQ = 0.0D+0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0D+0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0D+0 + DO I = 2*N+1, 3*N + WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG + END DO + CALL ZLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + + D = C1*C1 - 4*C0*C2 + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S(I) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO + + END DO + + 999 CONTINUE + + SMLNUM = DLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT( AVG ) + BASE = DLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + + END diff --git a/SRC/zheev.f b/SRC/zheev.f index 324d1612..d447e03e 100644 --- a/SRC/zheev.f +++ b/SRC/zheev.f @@ -1,7 +1,7 @@ SUBROUTINE ZHEEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zheevd.f b/SRC/zheevd.f index d8258374..25aefc02 100644 --- a/SRC/zheevd.f +++ b/SRC/zheevd.f @@ -1,7 +1,7 @@ SUBROUTINE ZHEEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zheevr.f b/SRC/zheevr.f index af8c9fcb..187bb3bc 100644 --- a/SRC/zheevr.f +++ b/SRC/zheevr.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zheevx.f b/SRC/zheevx.f index 4c378ce2..42485003 100644 --- a/SRC/zheevx.f +++ b/SRC/zheevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhegs2.f b/SRC/zhegs2.f index 3b2141d5..e86bc36e 100644 --- a/SRC/zhegs2.f +++ b/SRC/zhegs2.f @@ -1,6 +1,6 @@ SUBROUTINE ZHEGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhegst.f b/SRC/zhegst.f index 0d50d367..6deed6f2 100644 --- a/SRC/zhegst.f +++ b/SRC/zhegst.f @@ -1,6 +1,6 @@ SUBROUTINE ZHEGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhegv.f b/SRC/zhegv.f index ded1b580..a93eea93 100644 --- a/SRC/zhegv.f +++ b/SRC/zhegv.f @@ -1,7 +1,7 @@ SUBROUTINE ZHEGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhegvd.f b/SRC/zhegvd.f index b5b72ca3..0cc26a9e 100644 --- a/SRC/zhegvd.f +++ b/SRC/zhegvd.f @@ -1,7 +1,7 @@ SUBROUTINE ZHEGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhegvx.f b/SRC/zhegvx.f index f810c412..8bd07b11 100644 --- a/SRC/zhegvx.f +++ b/SRC/zhegvx.f @@ -2,7 +2,7 @@ $ VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, $ LWORK, RWORK, IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zherfs.f b/SRC/zherfs.f index 6d5afca9..b4d6626e 100644 --- a/SRC/zherfs.f +++ b/SRC/zherfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZHERFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zherfsx.f b/SRC/zherfsx.f new file mode 100644 index 00000000..c0b3d6fb --- /dev/null +++ b/SRC/zherfsx.f @@ -0,0 +1,573 @@ + Subroutine ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* +* Purpose +* ======= +* +* ZHERFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is Hermitian indefinite, and +* provides error bounds and backward error estimates for the +* solution. In addition to normwise error bound, the code provides +* maximum componentwise error bound if possible. See comments for +* ERR_BNDS_N and ERR_BNDS_C for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX*16 array, dimension (LDAF,N) +* The factored form of the matrix A. AF contains the block +* diagonal matrix D and the multipliers used to obtain the +* factor U or L from the factorization A = U*D*U**T or A = +* L*D*L**T as computed by DSYTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by DSYTRF. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) COMPLEX*16 array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHECON, ZLA_HERFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, ZLANHE, ZLA_HERCOND_X, ZLA_HERCOND_C + DOUBLE PRECISION DLAMCH, ZLANHE, ZLA_HERCOND_X, ZLA_HERCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS(LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHERFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = ZLANHE( NORM, UPLO, N, A, LDA, WORK ) + CALL ZHECON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK(N+1), WORK(1), WORK(2*N+1), WORK(1), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = ZLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = ZLA_HERCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF (RCOND_TMP .LT. ILLRCOND_THRESH) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = ZLA_HERCOND_X( UPLO, N, A, LDA, AF, LDAF, + $ IPIV, X( 1, J ), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of ZHERFSX +* + END diff --git a/SRC/zhesv.f b/SRC/zhesv.f index 0d661b48..728d83f1 100644 --- a/SRC/zhesv.f +++ b/SRC/zhesv.f @@ -1,7 +1,7 @@ SUBROUTINE ZHESV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhesvx.f b/SRC/zhesvx.f index e41b732b..6a27e6d3 100644 --- a/SRC/zhesvx.f +++ b/SRC/zhesvx.f @@ -2,7 +2,7 @@ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhesvxx.f b/SRC/zhesvxx.f new file mode 100644 index 00000000..6384faa7 --- /dev/null +++ b/SRC/zhesvxx.f @@ -0,0 +1,558 @@ + SUBROUTINE ZHESVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ WORK( * ), X( LDX, * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* ZHESVXX uses the diagonal pivoting factorization to compute the +* solution to a complex*16 system of linear equations A * X = B, where +* A is an N-by-N symmetric matrix and X and B are N-by-NRHS +* matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. ZHESVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* ZHESVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* ZHESVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what ZHESVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = U * D * U**T, if UPLO = 'U', or +* A = L * D * L**T, if UPLO = 'L', +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* 3. If some D(i,i)=0, so that D is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is +* less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(R) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T as computed by DSYTRF. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains details of the interchanges and the block +* structure of D, as determined by DSYTRF. If IPIV(k) > 0, +* then rows and columns k and IPIV(k) were interchanged and +* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +* then rows and columns k+1 and -IPIV(k) were interchanged +* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains details of the interchanges and the block +* structure of D, as determined by DSYTRF. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX*16 array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) COMPLEX*16 array, dimension (2*N) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, ZLA_HERPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLA_HERPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ZHECON, ZHEEQUB, ZHETRF, ZHETRS, ZLACPY, + $ ZLAQHE, XERBLA, ZLASCL2, ZHERFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in ZHERFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until ZHERFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHESVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL ZHEEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL ZLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL ZHETRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF( N.GT.0 ) + $ RPVGRW = ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF( N.GT.0 ) + $ RPVGRW = ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, IPIV, + $ WORK ) +* +* Compute the solution matrix X. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL ZHETRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL ZHERFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL ZLASCL2 ( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of ZHESVXX +* + END diff --git a/SRC/zhetd2.f b/SRC/zhetd2.f index 24b0a1df..0b2652e4 100644 --- a/SRC/zhetd2.f +++ b/SRC/zhetd2.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETD2( UPLO, N, A, LDA, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhetf2.f b/SRC/zhetf2.f index 67ea49d7..3ce3f792 100644 --- a/SRC/zhetf2.f +++ b/SRC/zhetf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhetrd.f b/SRC/zhetrd.f index fb0cd0b2..fcf57d29 100644 --- a/SRC/zhetrd.f +++ b/SRC/zhetrd.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhetrf.f b/SRC/zhetrf.f index 173d0766..717c2a94 100644 --- a/SRC/zhetrf.f +++ b/SRC/zhetrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhetri.f b/SRC/zhetri.f index 0cc08941..55e53d36 100644 --- a/SRC/zhetri.f +++ b/SRC/zhetri.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhetrs.f b/SRC/zhetrs.f index 2e49a51a..0dd05f16 100644 --- a/SRC/zhetrs.f +++ b/SRC/zhetrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhfrk.f b/SRC/zhfrk.f new file mode 100644 index 00000000..44cba760 --- /dev/null +++ b/SRC/zhfrk.f @@ -0,0 +1,478 @@ + SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, + + C ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER K, LDA, N + CHARACTER TRANS, TRANSR, UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for C in RFP Format. +* +* ZHFRK performs one of the Hermitian rank--k operations +* +* C := alpha*A*conjg( A' ) + beta*C, +* +* or +* +* C := alpha*conjg( A' )*A + beta*C, +* +* where alpha and beta are real scalars, C is an n--by--n Hermitian +* matrix and A is an n--by--k matrix in the first case and a k--by--n +* matrix in the second case. +* +* Arguments +* ========== +* +* TRANSR (input) CHARACTER. +* = 'N': The Normal Form of RFP A is stored; +* = 'C': The Conjugate-transpose Form of RFP A is stored. +* +* UPLO - (input) CHARACTER. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array C is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of C +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of C +* is to be referenced. +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. +* +* TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. +* +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the order of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - (input) INTEGER. +* On entry with TRANS = 'N' or 'n', K specifies the number +* of columns of the matrix A, and on entry with +* TRANS = 'C' or 'c', K specifies the number of rows of the +* matrix A. K must be at least zero. +* Unchanged on exit. +* +* ALPHA - (input) DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - (input) COMPLEX*16 array of DIMENSION ( LDA, ka ), where KA +* is K when TRANS = 'N' or 'n', and is N otherwise. Before +* entry with TRANS = 'N' or 'n', the leading N--by--K part of +* the array A must contain the matrix A, otherwise the leading +* K--by--N part of the array A must contain the matrix A. +* Unchanged on exit. +* +* LDA - (input) INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDA must be at least max( 1, n ), otherwise LDA must +* be at least max( 1, k ). +* Unchanged on exit. +* +* BETA - (input) DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. +* Unchanged on exit. +* +* C - (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ). +* On entry, the matrix A in RFP Format. RFP Format is +* described by TRANSR, UPLO and N. Note that the imaginary +* parts of the diagonal elements need not be set, they are +* assumed to be zero, and on exit they are set to zero. +* +* Arguments +* ========== +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + COMPLEX*16 CZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR, NISODD, NOTRANS + INTEGER INFO, NROWA, J, NK, N1, N2 + COMPLEX*16 CALPHA, CBETA +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, DCMPLX +* .. +* .. Executable Statements .. +* +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) +* + IF( NOTRANS ) THEN + NROWA = N + ELSE + NROWA = K + END IF +* + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZHFRK ', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* +* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not +* done (it is in ZHERK for example) and left in the general case. +* + IF( ( N.EQ.0 ) .OR. ( ( ( ALPHA.EQ.ZERO ) .OR. ( K.EQ.0 ) ) .AND. + + ( BETA.EQ.ONE ) ) )RETURN +* + IF( ( ALPHA.EQ.ZERO ) .AND. ( BETA.EQ.ZERO ) ) THEN + DO J = 1, ( ( N*( N+1 ) ) / 2 ) + C( J ) = CZERO + END DO + RETURN + END IF +* + CALPHA = DCMPLX( ALPHA, ZERO ) + CBETA = DCMPLX( BETA, ZERO ) +* +* C is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and NK. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + NK = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL ZHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL ZHERK( 'U', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N+1 ), N ) + CALL ZGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' +* + CALL ZHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N ) + CALL ZHERK( 'U', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N+1 ), N ) + CALL ZGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( N1+1 ), N ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL ZHERK( 'L', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL ZHERK( 'U', 'N', N2, K, ALPHA, A( N2, 1 ), LDA, + + BETA, C( N1+1 ), N ) + CALL ZGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( N2, 1 ), LDA, CBETA, C( 1 ), N ) +* + ELSE +* +* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' +* + CALL ZHERK( 'L', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2+1 ), N ) + CALL ZHERK( 'U', 'C', N2, K, ALPHA, A( 1, N2 ), LDA, + + BETA, C( N1+1 ), N ) + CALL ZGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, N2 ), LDA, CBETA, C( 1 ), N ) +* + END IF +* + END IF +* + ELSE +* +* N is odd, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* N is odd, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' +* + CALL ZHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL ZHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL ZGEMM( 'N', 'C', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( N1+1, 1 ), LDA, CBETA, + + C( N1*N1+1 ), N1 ) +* + ELSE +* +* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' +* + CALL ZHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 1 ), N1 ) + CALL ZHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( 2 ), N1 ) + CALL ZGEMM( 'C', 'N', N1, N2, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, N1+1 ), LDA, CBETA, + + C( N1*N1+1 ), N1 ) +* + END IF +* + ELSE +* +* N is odd, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' +* + CALL ZHERK( 'U', 'N', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL ZHERK( 'L', 'N', N2, K, ALPHA, A( N1+1, 1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL ZGEMM( 'N', 'C', N2, N1, K, CALPHA, A( N1+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 ) +* + ELSE +* +* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' +* + CALL ZHERK( 'U', 'C', N1, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( N2*N2+1 ), N2 ) + CALL ZHERK( 'L', 'C', N2, K, ALPHA, A( 1, N1+1 ), LDA, + + BETA, C( N1*N2+1 ), N2 ) + CALL ZGEMM( 'C', 'N', N2, N1, K, CALPHA, A( 1, N1+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), N2 ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' +* + CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' +* + CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( 2 ), N+1 ) + CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), N+1 ) + CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( NK+2 ), + + N+1 ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' +* + CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, CBETA, C( 1 ), + + N+1 ) +* + ELSE +* +* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' +* + CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+2 ), N+1 ) + CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK+1 ), N+1 ) + CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, CBETA, C( 1 ), + + N+1 ) +* + END IF +* + END IF +* + ELSE +* +* N is even, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* N is even, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' +* + CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( 1 ), NK ) + CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( NK+1, 1 ), LDA, CBETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' +* + CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK+1 ), NK ) + CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( 1 ), NK ) + CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, 1 ), + + LDA, A( 1, NK+1 ), LDA, CBETA, + + C( ( ( NK+1 )*NK )+1 ), NK ) +* + END IF +* + ELSE +* +* N is even, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' +* + CALL ZHERK( 'U', 'N', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL ZHERK( 'L', 'N', NK, K, ALPHA, A( NK+1, 1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL ZGEMM( 'N', 'C', NK, NK, K, CALPHA, A( NK+1, 1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK ) +* + ELSE +* +* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' +* + CALL ZHERK( 'U', 'C', NK, K, ALPHA, A( 1, 1 ), LDA, + + BETA, C( NK*( NK+1 )+1 ), NK ) + CALL ZHERK( 'L', 'C', NK, K, ALPHA, A( 1, NK+1 ), LDA, + + BETA, C( NK*NK+1 ), NK ) + CALL ZGEMM( 'C', 'N', NK, NK, K, CALPHA, A( 1, NK+1 ), + + LDA, A( 1, 1 ), LDA, CBETA, C( 1 ), NK ) +* + END IF +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZHFRK +* + END diff --git a/SRC/zhgeqz.f b/SRC/zhgeqz.f index 6a9403bd..fd40a82b 100644 --- a/SRC/zhgeqz.f +++ b/SRC/zhgeqz.f @@ -2,7 +2,7 @@ $ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpcon.f b/SRC/zhpcon.f index 5b30e756..0df945a8 100644 --- a/SRC/zhpcon.f +++ b/SRC/zhpcon.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpev.f b/SRC/zhpev.f index 896d9d3a..2b363b93 100644 --- a/SRC/zhpev.f +++ b/SRC/zhpev.f @@ -1,7 +1,7 @@ SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, $ INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpevd.f b/SRC/zhpevd.f index 614a5ea6..13394374 100644 --- a/SRC/zhpevd.f +++ b/SRC/zhpevd.f @@ -1,7 +1,7 @@ SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpevx.f b/SRC/zhpevx.f index 57bc2de0..ad9a3915 100644 --- a/SRC/zhpevx.f +++ b/SRC/zhpevx.f @@ -2,7 +2,7 @@ $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, $ IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -336,7 +336,7 @@ * INDWRK = INDTAU + N CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, - $ WORK( INDWRK ), INFO ) + $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. diff --git a/SRC/zhpgst.f b/SRC/zhpgst.f index 2a9fca87..ad1163f8 100644 --- a/SRC/zhpgst.f +++ b/SRC/zhpgst.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpgv.f b/SRC/zhpgv.f index 5cc78079..799d21c3 100644 --- a/SRC/zhpgv.f +++ b/SRC/zhpgv.f @@ -1,7 +1,7 @@ SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpgvd.f b/SRC/zhpgvd.f index b50538c9..c69a3d6b 100644 --- a/SRC/zhpgvd.f +++ b/SRC/zhpgvd.f @@ -1,7 +1,7 @@ SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, $ LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpgvx.f b/SRC/zhpgvx.f index bdbc69ae..43fa7244 100644 --- a/SRC/zhpgvx.f +++ b/SRC/zhpgvx.f @@ -2,7 +2,7 @@ $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhprfs.f b/SRC/zhprfs.f index a2f8df9b..58fbf6a9 100644 --- a/SRC/zhprfs.f +++ b/SRC/zhprfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpsv.f b/SRC/zhpsv.f index abdb122e..5ba5394d 100644 --- a/SRC/zhpsv.f +++ b/SRC/zhpsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhpsvx.f b/SRC/zhpsvx.f index cdf67346..30762a1b 100644 --- a/SRC/zhpsvx.f +++ b/SRC/zhpsvx.f @@ -1,7 +1,7 @@ SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhptrd.f b/SRC/zhptrd.f index 9a554ae9..565353ef 100644 --- a/SRC/zhptrd.f +++ b/SRC/zhptrd.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhptrf.f b/SRC/zhptrf.f index b91179e3..723c5c3b 100644 --- a/SRC/zhptrf.f +++ b/SRC/zhptrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhptri.f b/SRC/zhptri.f index b41b9b99..59dd6767 100644 --- a/SRC/zhptri.f +++ b/SRC/zhptri.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhptrs.f b/SRC/zhptrs.f index 70719393..a1fc9745 100644 --- a/SRC/zhptrs.f +++ b/SRC/zhptrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhsein.f b/SRC/zhsein.f index 2cd0b80b..1f4f2c33 100644 --- a/SRC/zhsein.f +++ b/SRC/zhsein.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, $ IFAILR, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zhseqr.f b/SRC/zhseqr.f index fb721dad..9e90b227 100644 --- a/SRC/zhseqr.f +++ b/SRC/zhseqr.f @@ -1,8 +1,8 @@ SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, $ WORK, LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK driver routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -95,9 +95,11 @@ * * LWORK (input) INTEGER * The dimension of the array WORK. LWORK .GE. max(1,N) -* is sufficient, but LWORK typically as large as 6*N may -* be required for optimal performance. A workspace query -* to determine the optimal workspace size is recommended. +* is sufficient and delivers very good and sometimes +* optimal performance. However, LWORK as large as 11*N +* may be required for optimal performance. A workspace +* query is recommended to determine the optimal workspace +* size. * * If LWORK = -1, then ZHSEQR does a workspace query. * In this case, ZHSEQR checks the input parameters and @@ -152,46 +154,50 @@ * to attain best performance in each particular * computational environment. * -* ISPEC=1: The ZLAHQR vs ZLAQR0 crossover point. +* ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. * Default: 75. (Must be at least 11.) * -* ISPEC=2: Recommended deflation window size. +* ISPEC=13: Recommended deflation window size. * This depends on ILO, IHI and NS. NS is the * number of simultaneous shifts returned -* by ILAENV(ISPEC=4). (See ISPEC=4 below.) +* by ILAENV(ISPEC=15). (See ISPEC=15 below.) * The default for (IHI-ILO+1).LE.500 is NS. * The default for (IHI-ILO+1).GT.500 is 3*NS/2. * -* ISPEC=3: Nibble crossover point. (See ILAENV for +* ISPEC=14: Nibble crossover point. (See IPARMQ for * details.) Default: 14% of deflation window * size. * -* ISPEC=4: Number of simultaneous shifts, NS, in -* a multi-shift QR iteration. +* ISPEC=15: Number of simultaneous shifts in a multishift +* QR iteration. * * If IHI-ILO+1 is ... * * greater than ...but less ... the * or equal to ... than default is * -* 1 30 NS - 2(+) -* 30 60 NS - 4(+) +* 1 30 NS = 2(+) +* 30 60 NS = 4(+) * 60 150 NS = 10(+) * 150 590 NS = ** * 590 3000 NS = 64 * 3000 6000 NS = 128 * 6000 infinity NS = 256 * -* (+) By default some or all matrices of this order +* (+) By default some or all matrices of this order * are passed to the implicit double shift routine -* ZLAHQR and NS is ignored. See ISPEC=1 above -* and comments in IPARM for details. +* ZLAHQR and this parameter is ignored. See +* ISPEC=12 above and comments in IPARMQ for +* details. * -* The asterisks (**) indicate an ad-hoc +* (**) The asterisks (**) indicate an ad-hoc * function of N increasing from 10 to 64. * -* ISPEC=5: Select structured matrix multiply. -* (See ILAENV for details.) Default: 3. +* ISPEC=16: Select structured matrix multiply. +* If the number of simultaneous shifts (specified +* by ISPEC=15) is less than 14, then the default +* for ISPEC=16 is 0. Otherwise the default for +* ISPEC=16 is 2. * * ================================================================ * Based on contributions by @@ -215,16 +221,15 @@ * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== NL allocates some local workspace to help small matrices * . through a rare ZLAHQR failure. NL .GT. NTINY = 11 is -* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom- +* . required and NL .LE. NMIN = ILAENV(ISPEC=12,...) is recom- * . mended. (The default value of NMIN is 75.) Using NL = 49 * . allows up to six simultaneous shifts and a 16-by-16 * . deflation window. ==== -* - INTEGER NTINY - PARAMETER ( NTINY = 11 ) INTEGER NL PARAMETER ( NL = 49 ) COMPLEX*16 ZERO, ONE @@ -328,8 +333,8 @@ * * ==== ZLAHQR/ZLAQR0 crossover point ==== * - NMIN = ILAENV( 1, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO, - $ IHI, LWORK ) + NMIN = ILAENV( 12, 'ZHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, + $ ILO, IHI, LWORK ) NMIN = MAX( NTINY, NMIN ) * * ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== diff --git a/SRC/zla_gbamv.f b/SRC/zla_gbamv.f new file mode 100644 index 00000000..9bc101fb --- /dev/null +++ b/SRC/zla_gbamv.f @@ -0,0 +1,290 @@ + SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, + $ INCX, BETA, Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 AB( LDAB, * ), X( * ) + DOUBLE PRECISION Y( * ) +* .. +* +* Purpose +* ======= +* +* DLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* KL - INTEGER +* The number of subdiagonals within the band of A. KL >= 0. +* +* KU - INTEGER +* The number of superdiagonals within the band of A. KU >= 0. +* +* ALPHA - DOUBLE PRECISION +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* .. +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY, KD + COMPLEX*16 CDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, REAL, DIMAG, SIGN +* .. +* .. Statement Functions + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( KL.LT.0 ) THEN + INFO = 4 + ELSE IF( KU.LT.0 ) THEN + INFO = 5 + ELSE IF( LDAB.LT.KL+KU+1 )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZLA_GBAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + KD = KU + 1 + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0D+0 ) THEN + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( AB( KD+I-J, J ) ) + ELSE + TEMP = CABS1( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0D+0 ) THEN + JX = KX + DO J = MAX( I-KU, 1 ), MIN( I+KL, LENX ) + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( AB( KD+I-J, J ) ) + ELSE + TEMP = CABS1( AB( J, KD+I-J ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZLA_GBAMV +* + END diff --git a/SRC/zla_gbrcond_c.f b/SRC/zla_gbrcond_c.f new file mode 100644 index 00000000..92162f2f --- /dev/null +++ b/SRC/zla_gbrcond_c.f @@ -0,0 +1,192 @@ + DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, + $ LDAB, AFB, LDAFB, IPIV, C, CAPPLY, + $ INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + LOGICAL CAPPLY + INTEGER N, KL, KU, KD, LDAB, LDAFB, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) + DOUBLE PRECISION C( * ), RWORK( * ) +* +* ZLA_GBRCOND_C Computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + ZLA_GBRCOND_C = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_GBRCOND_C', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + KD = KU + 1 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1(AB( KD+I-J, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( KD+I-J, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( J, KD+I-J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) + $ .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( J, KD+I-J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_GBRCOND_C = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( NOTRANS ) THEN + CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( NOTRANS ) THEN + CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ELSE + CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_GBRCOND_C = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_gbrcond_x.f b/SRC/zla_gbrcond_x.f new file mode 100644 index 00000000..f2decc47 --- /dev/null +++ b/SRC/zla_gbrcond_x.f @@ -0,0 +1,170 @@ + DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, + $ LDAB, AFB, LDAFB, IPIV, X, INFO, + $ WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, KL, KU, KD, LDAB, LDAFB, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), + $ X( * ) + DOUBLE PRECISION RWORK( * ) +* +* ZLA_GBRCOND_X Computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX*16 vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZGBTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_GBRCOND_X = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME(TRANS, 'T') .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_GBRCOND_X', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + KD = KU + 1 + ANORM = 0.0D+0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( KD+I-J, J) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.GE.MAX( 1, J-KU ) .AND. I.LE.MIN( N, J+KL ) ) THEN + TMP = TMP + CABS1( AB( J, KD+I-J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_GBRCOND_X = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( NOTRANS ) THEN + CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + ELSE + CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( NOTRANS ) THEN + CALL ZGBTRS( 'Conjugate transpose', N, KL, KU, 1, AFB, + $ LDAFB, IPIV, WORK, N, INFO ) + ELSE + CALL ZGBTRS( 'No transpose', N, KL, KU, 1, AFB, LDAFB, + $ IPIV, WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_GBRCOND_X = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_gbrfsx_extended.f b/SRC/zla_gbrfsx_extended.f new file mode 100644 index 00000000..33b3c42a --- /dev/null +++ b/SRC/zla_gbrfsx_extended.f @@ -0,0 +1,310 @@ + SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, + $ NRHS, AB, LDAB, AFB, LDAFB, IPIV, + $ COLEQU, C, B, LDB, Y, LDY, + $ BERR_OUT, N_NORMS, ERRS_N, ERRS_C, + $ RES, AYB, DY, Y_TAIL, RCOND, + $ ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, + $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX*16 ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGBTRS, ZGBMV, BLAS_ZGBMV_X, + $ BLAS_ZGBMV2_X, ZLA_GBAMV, ZLA_WWADDW, DLAMCH, + $ CHLA_TRANSTYPE, ZLA_LIN_BERR + DOUBLE PRECISION DLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions.. + INTRINSIC ABS, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + M = KL+KU+1 + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) then + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL ZGBMV( TRANS, M, N, KL, KU, (-1.0D+0,0.0D+0), AB, + $ LDAB, Y( 1, J ), 1, (1.0D+0,0.0D+0), RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_ZGBMV_X( TRANS_TYPE, N, N, KL, KU, + $ (-1.0D+0,0.0D+0), AB, LDAB, Y( 1, J ), 1, + $ (1.0D+0,0.0D+0), RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_ZGBMV2_X( TRANS_TYPE, N, N, KL, KU, + $ (-1.0D+0,0.0D+0), AB, LDAB, Y( 1, J ), Y_TAIL, 1, + $ (1.0D+0,0.0D+0), RES, 1, PREC_TYPE ) + END IF + +! XXX: RES is no longer needed. + CALL ZCOPY( N, RES, 1, DY, 1 ) + CALL ZGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV, DY, N, + $ INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF (YK .NE. 0.0D+0) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX(NORMDX, DYK * C(I)) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL ZAXPY( N, (1.0D+0,0.0D+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL ZLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL ZGBMV( TRANS, N, N, KL, KU, (-1.0D+0,0.0D+0), AB, LDAB, + $ Y(1,J), 1, (1.0D+0,0.0D+0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL ZLA_GBAMV( TRANS_TYPE, N, N, KL, KU, 1.0D+0, + $ AB, LDAB, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL ZLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/zla_gbrpvgrw.f b/SRC/zla_gbrpvgrw.f new file mode 100644 index 00000000..d6366c93 --- /dev/null +++ b/SRC/zla_gbrpvgrw.f @@ -0,0 +1,53 @@ + DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, + $ LDAB, AFB, LDAFB ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, KL, KU, NCOLS, LDAB, LDAFB +* .. +* .. Array Arguments .. + COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ) +* .. +* .. Local Scalars .. + INTEGER I, J, KD + DOUBLE PRECISION AMAX, UMAX, RPVGRW + COMPLEX*16 ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0D+0 +* + KD = KU + 1 + DO J = 1, NCOLS + AMAX = 0.0D+0 + UMAX = 0.0D+0 + DO I = MAX( J-KU, 1 ), MIN( J+KL, N ) + AMAX = MAX( CABS1( AB( KD+I-J, J ) ), AMAX ) + END DO + DO I = MAX( J-KU, 1 ), J + UMAX = MAX( CABS1( AFB( KD+I-J, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ZLA_GBRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/zla_geamv.f b/SRC/zla_geamv.f new file mode 100644 index 00000000..135ee5e6 --- /dev/null +++ b/SRC/zla_geamv.f @@ -0,0 +1,280 @@ + SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, + $ Y, INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + INTEGER TRANS +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) + DOUBLE PRECISION Y( * ) +* .. +* +* Purpose +* ======= +* +* ZLA_GEAMV performs one of the matrix-vector operations +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* or y := alpha*abs(A)'*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* TRANS - INTEGER +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) +* BLAS_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* BLAS_CONJ_TRANS y := alpha*abs(A')*abs(x) + beta*abs(y) +* +* Unchanged on exit. +* +* M - INTEGER +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - COMPLEX*16 array of DIMENSION ( LDA, n ) +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - COMPLEX*16 array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* .. +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY, LENX, LENY + COMPLEX*16 CDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILATRANS + INTEGER ILATRANS +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, REAL, DIMAG, SIGN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.( ( TRANS.EQ.ILATRANS( 'N' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'T' ) ) + $ .OR. ( TRANS.EQ.ILATRANS( 'C' ) ) ) ) THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZLA_GEAMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, LENY + IF ( BETA .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0D+0 ) THEN + DO J = 1, LENX + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) Y( IY ) = + $ Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, LENY + IF ( BETA .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. 0.0D+0 ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. 0.0D+0 ) THEN + JX = KX + DO J = 1, LENX + + IF( TRANS.EQ.ILATRANS( 'N' ) )THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( JX ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) Y( IY ) = + $ Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZLA_GEAMV +* + END diff --git a/SRC/zla_gercond_c.f b/SRC/zla_gercond_c.f new file mode 100644 index 00000000..a4cf0926 --- /dev/null +++ b/SRC/zla_gercond_c.f @@ -0,0 +1,179 @@ + DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, + $ LDAF, IPIV, C, CAPPLY, INFO, WORK, + $ RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Aguments .. + CHARACTER TRANS + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) + DOUBLE PRECISION C( * ), RWORK( * ) +* +* ZLA_GERCOND_C computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + ZLA_GERCOND_C = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_GERCOND_C', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END DO + ELSE + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) ) + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + END DO + ELSE + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) ) + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_GERCOND_C = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF (NOTRANS) THEN + CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( NOTRANS ) THEN + CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_GERCOND_C = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_gercond_x.f b/SRC/zla_gercond_x.f new file mode 100644 index 00000000..4ed6faa0 --- /dev/null +++ b/SRC/zla_gercond_x.f @@ -0,0 +1,162 @@ + DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, + $ LDAF, IPIV, X, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + DOUBLE PRECISION RWORK( * ) +* +* ZLA_GERCOND_X computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX*16 vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + LOGICAL NOTRANS + INTEGER KASE + DOUBLE PRECISION AINVNM, ANORM, TMP + INTEGER I, J + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_GERCOND_X = 0.0D+0 +* + INFO = 0 + NOTRANS = LSAME( TRANS, 'N' ) + IF ( .NOT. NOTRANS .AND. .NOT. LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_GERCOND_X', -INFO ) + RETURN + END IF +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( NOTRANS ) THEN + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_GERCOND_X = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* Multiply by R. + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( NOTRANS ) THEN + CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( NOTRANS ) THEN + CALL ZGETRS( 'Conjugate transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZGETRS( 'No transpose', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_GERCOND_X = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_gerfsx_extended.f b/SRC/zla_gerfsx_extended.f new file mode 100644 index 00000000..2953878d --- /dev/null +++ b/SRC/zla_gerfsx_extended.f @@ -0,0 +1,310 @@ + SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, + $ LDA, AF, LDAF, IPIV, COLEQU, C, B, + $ LDB, Y, LDY, BERR_OUT, N_NORMS, + $ ERRS_N, ERRS_C, RES, AYB, DY, + $ Y_TAIL, RCOND, ITHRESH, RTHRESH, + $ DZ_UB, IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ TRANS_TYPE, N_NORMS + LOGICAL COLEQU, IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + CHARACTER TRANS + INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX*16 ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, + $ NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZGETRS, ZGEMV, BLAS_ZGEMV_X, + $ BLAS_ZGEMV2_X, ZLA_GEAMV, ZLA_WWADDW, DLAMCH, + $ CHLA_TRANSTYPE, ZLA_LIN_BERR + DOUBLE PRECISION DLAMCH + CHARACTER CHLA_TRANSTYPE +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + TRANS = CHLA_TRANSTYPE(TRANS_TYPE) + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS +* + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL ZGEMV( TRANS, N, N, (-1.0D+0,0.0D+0), A, LDA, + $ Y( 1, J ), 1, (1.0D+0,0.0D+0), RES, 1) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_ZGEMV_X( TRANS_TYPE, N, N, (-1.0D+0,0.0D+0), A, + $ LDA, Y( 1, J ), 1, (1.0D+0,0.0D+0), + $ RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_ZGEMV2_X( TRANS_TYPE, N, N, (-1.0D+0,0.0D+0), + $ A, LDA, Y(1, J), Y_TAIL, 1, (1.0D+0,0.0D+0), RES, 1, + $ PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL ZCOPY( N, RES, 1, DY, 1 ) + CALL ZGETRS( TRANS, N, 1, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL +* + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria +* + IF (.NOT.IGNORE_CWISE + $ .AND. YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF (DX_X .LE. EPS) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF ( DXRAT .GT. DXRATMAX ) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF +* +* Exit if both normwise and componentwise stopped working, +* but if componentwise is unstable, let it go at least two +* iterations. +* + IF ( X_STATE.NE.WORKING_STATE ) THEN + IF ( IGNORE_CWISE ) GOTO 666 + IF ( Z_STATE.EQ.NOPROG_STATE .OR. Z_STATE.EQ.CONV_STATE ) + $ GOTO 666 + IF ( Z_STATE.EQ.UNSTABLE_STATE .AND. CNT.GT.1 ) GOTO 666 + END IF + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL ZAXPY( N, (1.0D+0,0.0D+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL ZLA_WWADDW( N, Y( 1, J ), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL ZGEMV( TRANS, N, N, (-1.0D+0,0.0D+0), A, LDA, Y(1,J), 1, + $ (1.0D+0,0.0D+0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL ZLA_GEAMV ( TRANS_TYPE, N, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL ZLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/zla_heamv.f b/SRC/zla_heamv.f new file mode 100644 index 00000000..d9181914 --- /dev/null +++ b/SRC/zla_heamv.f @@ -0,0 +1,283 @@ + SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N, UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) + DOUBLE PRECISION Y( * ) +* .. +* +* Purpose +* ======= +* +* ZLA_SYAMV performs the matrix-vector operation +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* n by n symmetric matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* UPLO - INTEGER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = BLAS_UPPER Only the upper triangular part of A +* is to be referenced. +* +* UPLO = BLAS_LOWER Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION . +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - COMPLEX*16 array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - COMPLEX*16 array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION . +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCY ) ) +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* -- Modified for the absolute-value product, April 2006 +* Jason Riedy, UC Berkeley +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY + COMPLEX*16 ZDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'ZHEMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF (.NOT.SYMB_ZERO) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZLA_HEAMV +* + END diff --git a/SRC/zla_hercond_c.f b/SRC/zla_hercond_c.f new file mode 100644 index 00000000..474a6d7b --- /dev/null +++ b/SRC/zla_hercond_c.f @@ -0,0 +1,195 @@ + DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, + $ LDAF, IPIV, C, CAPPLY, INFO, WORK, + $ RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) + DOUBLE PRECISION C ( * ), RWORK( * ) +* +* ZLA_HERCOND_C computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZHETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_HERCOND_C = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_HERCOND_C', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_HERCOND_C = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( UP ) THEN + CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_HERCOND_C = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_hercond_x.f b/SRC/zla_hercond_x.f new file mode 100644 index 00000000..fb7b3c9f --- /dev/null +++ b/SRC/zla_hercond_x.f @@ -0,0 +1,169 @@ + DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, + $ LDAF, IPIV, X, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + DOUBLE PRECISION RWORK( * ) +* +* ZLA_HERCOND_X computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX*16 vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZHETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_HERCOND_X = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_HERCOND_X', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_HERCOND_X = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( UP ) THEN + CALL ZHETRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZHETRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_HERCOND_X = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_herfsx_extended.f b/SRC/zla_herfsx_extended.f new file mode 100644 index 00000000..8d3e56bf --- /dev/null +++ b/SRC/zla_herfsx_extended.f @@ -0,0 +1,308 @@ + SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE, + $ Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX*16 ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZHETRS, ZHEMV, BLAS_ZHEMV_X, + $ BLAS_ZHEMV2_X, ZLA_HEAMV, ZLA_WWADDW, + $ ZLA_LIN_BERR + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL ZHEMV( UPLO, N, DCMPLX(-1.0D+0), A, LDA, Y( 1, J ), + $ 1, DCMPLX(1.0D+0), RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_ZHEMV_X( UPLO2, N, DCMPLX(-1.0D+0), A, LDA, + $ Y( 1, J ), 1, DCMPLX(1.0D+0), RES, 1, PREC_TYPE) + ELSE + CALL BLAS_ZHEMV2_X(UPLO2, N, DCMPLX(-1.0D+0), A, LDA, + $ Y(1, J), Y_TAIL, 1, DCMPLX(1.0D+0), RES, 1, + $ PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL ZCOPY( N, RES, 1, DY, 1 ) + CALL ZHETRS( UPLO, N, NRHS, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF (YK .NE. 0.0D+0) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF (DXRAT .GT. DXRATMAX) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL ZAXPY( N, DCMPLX(1.0D+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL ZLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL ZHEMV( UPLO, N, DCMPLX(-1.0D+0), A, LDA, Y(1,J), 1, + $ DCMPLX(1.0D+0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL ZLA_HEAMV( UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL ZLA_LIN_BERR( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/zla_herpvgrw.f b/SRC/zla_herpvgrw.f new file mode 100644 index 00000000..e0e63f46 --- /dev/null +++ b/SRC/zla_herpvgrw.f @@ -0,0 +1,210 @@ + DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ) + DOUBLE PRECISION WORK( * ) +* .. +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER, LSAME + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + EXTERNAL LSAME, ZLASET +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF (UPPER) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0D+0 + DO I = 1, 2*N + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( CABS1( A( I,J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I,J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from zsytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = + $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = + $ MAX( CABS1( AF( I, K+1 ) ) , WORK( K+1 ) ) + END DO + WORK(K) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + ZLA_HERPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/zla_lin_berr.f b/SRC/zla_lin_berr.f new file mode 100644 index 00000000..6246c45a --- /dev/null +++ b/SRC/zla_lin_berr.f @@ -0,0 +1,67 @@ + SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NZ, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) + COMPLEX*16 RES( N, NRHS ) +* +* ZLA_LIN_BERR computes componentwise relative backward error from +* the formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* .. +* .. Local Scalars .. + DOUBLE PRECISION TMP + INTEGER I, J + COMPLEX*16 CDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, DIMAG, MAX +* .. +* .. External Functions .. + EXTERNAL DLAMCH + DOUBLE PRECISION DLAMCH + DOUBLE PRECISION SAFE1 +* .. +* .. Statement Functions .. + COMPLEX*16 CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* Adding SAFE1 to the numerator guards against spuriously zero +* residuals. A similar safeguard is in the CLA_yyAMV routine used +* to compute AYB. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (NZ+1)*SAFE1 + + DO J = 1, NRHS + BERR(J) = 0.0D+0 + DO I = 1, N + IF (AYB(I,J) .NE. 0.0D+0) THEN + TMP = (SAFE1 + CABS1(RES(I,J)))/AYB(I,J) + BERR(J) = MAX( BERR(J), TMP ) + END IF +* +* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know +* the true residual also must be exactly 0.0. +* + END DO + END DO + END SUBROUTINE diff --git a/SRC/zla_porcond_c.f b/SRC/zla_porcond_c.f new file mode 100644 index 00000000..5ab1fdfc --- /dev/null +++ b/SRC/zla_porcond_c.f @@ -0,0 +1,194 @@ + DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, + $ LDAF, C, CAPPLY, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) + DOUBLE PRECISION C( * ), RWORK( * ) +* +* DLA_PORCOND_C Computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE + DOUBLE PRECISION AINVNM, ANORM, TMP + INTEGER I, J + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_PORCOND_C = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_PORCOND_C', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_PORCOND_C = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL ZPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL ZPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( UP ) THEN + CALL ZPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL ZPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_PORCOND_C = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_porcond_x.f b/SRC/zla_porcond_x.f new file mode 100644 index 00000000..95a366d9 --- /dev/null +++ b/SRC/zla_porcond_x.f @@ -0,0 +1,168 @@ + DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, + $ LDAF, X, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + DOUBLE PRECISION RWORK( * ) +* +* ZLA_PORCOND_X Computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX*16 vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE, I, J + DOUBLE PRECISION AINVNM, ANORM, TMP + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZPOTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_PORCOND_X = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_PORCOND_X', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_PORCOND_X = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL ZPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL ZPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( UP ) THEN + CALL ZPOTRS( 'U', N, 1, AF, LDAF, + $ WORK, N, INFO ) + ELSE + CALL ZPOTRS( 'L', N, 1, AF, LDAF, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_PORCOND_X = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_porfsx_extended.f b/SRC/zla_porfsx_extended.f new file mode 100644 index 00000000..e614b578 --- /dev/null +++ b/SRC/zla_porfsx_extended.f @@ -0,0 +1,307 @@ + SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, COLEQU, C, B, LDB, Y, + $ LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE, + $ Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX*16 ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZPOTRS, ZHEMV, BLAS_ZHEMV_X, + $ BLAS_ZHEMV2_X, ZLA_SYAMV, ZLA_WWADDW, + $ ZLA_LIN_BERR, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF (INFO.NE.0) RETURN + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE(N) * EPS + + IF (LSAME (UPLO, 'L')) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF (Y_PREC_STATE .EQ. EXTRA_Y) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + IF (Y_PREC_STATE .EQ. BASE_RESIDUAL) THEN + CALL ZHEMV(UPLO, N, DCMPLX(-1.0D+0), A, LDA, Y(1,J), 1, + $ DCMPLX(1.0D+0), RES, 1) + ELSE IF (Y_PREC_STATE .EQ. EXTRA_RESIDUAL) THEN + CALL BLAS_ZHEMV_X(UPLO2, N, DCMPLX(-1.0D+0), A, LDA, + $ Y( 1, J ), 1, DCMPLX(1.0D+0), RES, 1, PREC_TYPE) + ELSE + CALL BLAS_ZHEMV2_X(UPLO2, N, DCMPLX(-1.0D+0), A, LDA, + $ Y(1, J), Y_TAIL, 1, DCMPLX(1.0D+0), RES, 1, + $ PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL ZCOPY( N, RES, 1, DY, 1 ) + CALL ZPOTRS( UPLO, N, NRHS, AF, LDAF, DY, N, INFO) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1(Y(I, J)) + DYK = CABS1(DY(I)) + + IF (YK .NE. 0.0D+0) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF (DYK .NE. 0.0D+0) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX(NORMX, YK * C(I)) + NORMDX = MAX(NORMDX, DYK * C(I)) + ELSE + NORMX = NORMY + NORMDX = MAX(NORMDX, DYK) + END IF + END DO + + IF (NORMX .NE. 0.0D+0) THEN + DX_X = NORMDX / NORMX + ELSE IF (NORMDX .EQ. 0.0D+0) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF (YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y) + $ INCR_PREC = .TRUE. + + IF (X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH) + $ X_STATE = WORKING_STATE + IF (X_STATE .EQ. WORKING_STATE) THEN + IF (DX_X .LE. EPS) THEN + X_STATE = CONV_STATE + ELSE IF (DXRAT .GT. RTHRESH) THEN + IF (Y_PREC_STATE .NE. EXTRA_Y) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF (DXRAT .GT. DXRATMAX) DXRATMAX = DXRAT + END IF + IF (X_STATE .GT. WORKING_STATE) FINAL_DX_X = DX_X + END IF + + IF (Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB) + $ Z_STATE = WORKING_STATE + IF (Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH) + $ Z_STATE = WORKING_STATE + IF (Z_STATE .EQ. WORKING_STATE) THEN + IF (DZ_Z .LE. EPS) THEN + Z_STATE = CONV_STATE + ELSE IF (DZ_Z .GT. DZ_UB) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF (DZRAT .GT. RTHRESH) THEN + IF (Y_PREC_STATE .NE. EXTRA_Y) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF (DZRAT .GT. DZRATMAX) DZRATMAX = DZRAT + END IF + IF (Z_STATE .GT. WORKING_STATE) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ (IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE) ) + $ GOTO 666 + + IF (INCR_PREC) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF (Y_PREC_STATE .LT. EXTRA_Y) THEN + CALL ZAXPY( N, DCMPLX(1.0D+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL ZLA_WWADDW(N, Y(1,J), Y_TAIL, DY) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF (X_STATE .EQ. WORKING_STATE) FINAL_DX_X = DX_X + IF (Z_STATE .EQ. WORKING_STATE) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF (N_NORMS .GE. 1) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF (N_NORMS .GE. 2) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL ZHEMV(UPLO, N, DCMPLX(-1.0D+0), A, LDA, Y(1,J), 1, + $ DCMPLX(1.0D+0), RES, 1) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL ZLA_SYAMV (UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1) + + CALL ZLA_LIN_BERR (N, N, 1, RES, AYB, BERR_OUT(J)) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/zla_porpvgrw.f b/SRC/zla_porpvgrw.f new file mode 100644 index 00000000..3ae8ae56 --- /dev/null +++ b/SRC/zla_porpvgrw.f @@ -0,0 +1,114 @@ + DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, + $ LDAF, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ) + DOUBLE PRECISION WORK( * ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AMAX, UMAX, RPVGRW + LOGICAL UPPER + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + EXTERNAL LSAME, ZLASET + LOGICAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. + UPPER = LSAME( 'Upper', UPLO ) +* +* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so +* we restrict the growth search to that minor and use only the first +* 2*NCOLS workspace entries. +* + RPVGRW = 1.0D+0 + DO I = 1, 2*NCOLS + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column. +* + IF ( UPPER ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( NCOLS+J ) = + $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( NCOLS+J ) = + $ MAX( CABS1( A( I, J ) ), WORK( NCOLS+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of the factor in +* AF. No pivoting, so no permutations. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO J = 1, NCOLS + DO I = 1, J + WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) + END DO + END DO + ELSE + DO J = 1, NCOLS + DO I = J, NCOLS + WORK( J ) = MAX( CABS1( AF( I, J ) ), WORK( J ) ) + END DO + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( LSAME( 'Upper', UPLO ) ) THEN + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( NCOLS+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + ZLA_PORPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/zla_rpvgrw.f b/SRC/zla_rpvgrw.f new file mode 100644 index 00000000..68de32be --- /dev/null +++ b/SRC/zla_rpvgrw.f @@ -0,0 +1,51 @@ + DOUBLE PRECISION FUNCTION ZLA_RPVGRW( N, NCOLS, A, LDA, AF, LDAF ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N, NCOLS, LDA, LDAF +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION AMAX, UMAX, RPVGRW + COMPLEX*16 ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, ABS, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + RPVGRW = 1.0D+0 +* + DO J = 1, NCOLS + AMAX = 0.0D+0 + UMAX = 0.0D+0 + DO I = 1, N + AMAX = MAX( CABS1( A( I, J ) ), AMAX ) + END DO + DO I = 1, J + UMAX = MAX( CABS1( AF( I, J ) ), UMAX ) + END DO + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ZLA_RPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/zla_syamv.f b/SRC/zla_syamv.f new file mode 100644 index 00000000..e400d6a5 --- /dev/null +++ b/SRC/zla_syamv.f @@ -0,0 +1,284 @@ + SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, + $ INCY ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N + INTEGER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), X( * ) + DOUBLE PRECISION Y( * ) +* .. +* +* Purpose +* ======= +* +* ZLA_SYAMV performs the matrix-vector operation +* +* y := alpha*abs(A)*abs(x) + beta*abs(y), +* +* where alpha and beta are scalars, x and y are vectors and A is an +* n by n symmetric matrix. +* +* This function is primarily used in calculating error bounds. +* To protect against underflow during evaluation, components in +* the resulting vector are perturbed away from zero by (N+1) +* times the underflow threshold. To prevent unnecessarily large +* errors for block-structure embedded in general matrices, +* "symbolically" zero components are not perturbed. A zero +* entry is considered "symbolic" if all multiplications involved +* in computing that entry have at least one zero multiplicand. +* +* Parameters +* ========== +* +* UPLO - INTEGER +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = BLAS_UPPER Only the upper triangular part of A +* is to be referenced. +* +* UPLO = BLAS_LOWER Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION . +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - COMPLEX*16 array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - COMPLEX*16 array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION . +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCY ) ) +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* -- Modified for the absolute-value product, April 2006 +* Jason Riedy, UC Berkeley +* +* .. +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL SYMB_ZERO + DOUBLE PRECISION TEMP, SAFE1 + INTEGER I, INFO, IY, J, JX, KX, KY + COMPLEX*16 ZDUM +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLAMCH + DOUBLE PRECISION DLAMCH +* .. +* .. External Functions .. + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS, SIGN, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( UPLO.NE.ILAUPLO( 'U' ) .AND. + $ UPLO.NE.ILAUPLO( 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Set SAFE1 essentially to be the underflow threshold times the +* number of additions in each row. +* + SAFE1 = DLAMCH( 'Safe minimum' ) + SAFE1 = (N+1)*SAFE1 +* +* Form y := alpha*abs(A)*abs(x) + beta*abs(y). +* +* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to +* the inexact flag. Still doesn't help change the iteration order +* to per-column. +* + IY = KY + IF ( INCX.EQ.1 ) THEN + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( J ) )*TEMP + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + ELSE + DO I = 1, N + IF ( BETA .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + Y( IY ) = 0.0D+0 + ELSE IF ( Y( IY ) .EQ. ZERO ) THEN + SYMB_ZERO = .TRUE. + ELSE + SYMB_ZERO = .FALSE. + Y( IY ) = BETA * ABS( Y( IY ) ) + END IF + JX = KX + IF ( ALPHA .NE. ZERO ) THEN + DO J = 1, N + IF ( UPLO .EQ. ILAUPLO( 'U' ) ) THEN + IF ( I .LE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + ELSE + IF ( I .GE. J ) THEN + TEMP = CABS1( A( I, J ) ) + ELSE + TEMP = CABS1( A( J, I ) ) + END IF + END IF + + SYMB_ZERO = SYMB_ZERO .AND. + $ ( X( J ) .EQ. ZERO .OR. TEMP .EQ. ZERO ) + + Y( IY ) = Y( IY ) + ALPHA*CABS1( X( JX ) )*TEMP + JX = JX + INCX + END DO + END IF + + IF ( .NOT.SYMB_ZERO ) + $ Y( IY ) = Y( IY ) + SIGN( SAFE1, Y( IY ) ) + + IY = IY + INCY + END DO + END IF +* + RETURN +* +* End of ZLA_SYAMV +* + END diff --git a/SRC/zla_syrcond_c.f b/SRC/zla_syrcond_c.f new file mode 100644 index 00000000..ee10f8e6 --- /dev/null +++ b/SRC/zla_syrcond_c.f @@ -0,0 +1,196 @@ + DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, + $ LDAF, IPIV, C, CAPPLY, INFO, WORK, + $ RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + LOGICAL CAPPLY + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) + DOUBLE PRECISION C( * ), RWORK( * ) +* +* ZLA_SYRCOND_C Computes the infinity norm condition number of +* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE + DOUBLE PRECISION AINVNM, ANORM, TMP + INTEGER I, J + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_SYRCOND_C = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_SYRCOND_C', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF (I.GT.J) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + IF ( CAPPLY ) THEN + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) / C( J ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) / C( J ) + END IF + END DO + ELSE + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) ) + END IF + END DO + END IF + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_SYRCOND_C = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(C). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF + ELSE +* +* Multiply by inv(C'). +* + IF ( CAPPLY ) THEN + DO I = 1, N + WORK( I ) = WORK( I ) * C( I ) + END DO + END IF +* + IF ( UP ) THEN + CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_SYRCOND_C = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_syrcond_x.f b/SRC/zla_syrcond_x.f new file mode 100644 index 00000000..539853f7 --- /dev/null +++ b/SRC/zla_syrcond_x.f @@ -0,0 +1,170 @@ + DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, + $ LDAF, IPIV, X, INFO, WORK, RWORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER N, LDA, LDAF, INFO +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) + DOUBLE PRECISION RWORK( * ) +* +* ZLA_SYRCOND_X Computes the infinity norm condition number of +* op(A) * diag(X) where X is a COMPLEX*16 vector. +* WORK is a COMPLEX*16 workspace of size 2*N, and +* RWORK is a DOUBLE PRECISION workspace of size 3*N. +* .. +* .. Local Scalars .. + INTEGER KASE + DOUBLE PRECISION AINVNM, ANORM, TMP + INTEGER I, J + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. Local Arrays .. + INTEGER ISAVE( 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLACN2, ZSYTRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + ZLA_SYRCOND_X = 0.0D+0 +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZLA_SYRCOND_X', -INFO ) + RETURN + END IF + UP = .FALSE. + IF ( LSAME( UPLO, 'U' ) ) UP = .TRUE. +* +* Compute norm of op(A)*op2(C). +* + ANORM = 0.0D+0 + IF ( UP ) THEN + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.GT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + ELSE + DO I = 1, N + TMP = 0.0D+0 + DO J = 1, N + IF ( I.LT.J ) THEN + TMP = TMP + CABS1( A( J, I ) * X( J ) ) + ELSE + TMP = TMP + CABS1( A( I, J ) * X( J ) ) + END IF + END DO + RWORK( 2*N+I ) = TMP + ANORM = MAX( ANORM, TMP ) + END DO + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + ZLA_SYRCOND_X = 1.0D+0 + RETURN + ELSE IF( ANORM .EQ. 0.0D+0 ) THEN + RETURN + END IF +* +* Estimate the norm of inv(op(A)). +* + AINVNM = 0.0D+0 +* + KASE = 0 + 10 CONTINUE + CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE ) + IF( KASE.NE.0 ) THEN + IF( KASE.EQ.2 ) THEN +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO +* + IF ( UP ) THEN + CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ENDIF +* +* Multiply by inv(X). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO + ELSE +* +* Multiply by inv(X'). +* + DO I = 1, N + WORK( I ) = WORK( I ) / X( I ) + END DO +* + IF ( UP ) THEN + CALL ZSYTRS( 'U', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + ELSE + CALL ZSYTRS( 'L', N, 1, AF, LDAF, IPIV, + $ WORK, N, INFO ) + END IF +* +* Multiply by R. +* + DO I = 1, N + WORK( I ) = WORK( I ) * RWORK( 2*N+I ) + END DO + END IF + GO TO 10 + END IF +* +* Compute the estimate of the reciprocal condition number. +* + IF( AINVNM .NE. 0.0D+0 ) + $ ZLA_SYRCOND_X = 1.0D+0 / AINVNM +* + RETURN +* + END diff --git a/SRC/zla_syrfsx_extended.f b/SRC/zla_syrfsx_extended.f new file mode 100644 index 00000000..91f8bd29 --- /dev/null +++ b/SRC/zla_syrfsx_extended.f @@ -0,0 +1,308 @@ + SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, + $ AF, LDAF, IPIV, COLEQU, C, B, LDB, + $ Y, LDY, BERR_OUT, N_NORMS, ERRS_N, + $ ERRS_C, RES, AYB, DY, Y_TAIL, + $ RCOND, ITHRESH, RTHRESH, DZ_UB, + $ IGNORE_CWISE, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, + $ N_NORMS, ITHRESH + CHARACTER UPLO + LOGICAL COLEQU, IGNORE_CWISE + DOUBLE PRECISION RTHRESH, DZ_UB +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) + DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), + $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) +* .. +* .. Local Scalars .. + INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE, + $ Y_PREC_STATE + DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT, + $ DZRAT, PREVNORMDX, PREV_DZ_Z, DXRATMAX, + $ DZRATMAX, DX_X, DZ_Z, FINAL_DX_X, FINAL_DZ_Z, + $ EPS, HUGEVAL, INCR_THRESH + LOGICAL INCR_PREC + COMPLEX*16 ZDUM +* .. +* .. Parameters .. + INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE, + $ NOPROG_STATE, BASE_RESIDUAL, EXTRA_RESIDUAL, + $ EXTRA_Y + PARAMETER ( UNSTABLE_STATE = 0, WORKING_STATE = 1, + $ CONV_STATE = 2, NOPROG_STATE = 3 ) + PARAMETER ( BASE_RESIDUAL = 0, EXTRA_RESIDUAL = 1, + $ EXTRA_Y = 2 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL ILAUPLO + INTEGER ILAUPLO +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZCOPY, ZSYTRS, ZSYMV, BLAS_ZSYMV_X, + $ BLAS_ZSYMV2_X, ZLA_SYAMV, ZLA_WWADDW, + $ ZLA_LIN_BERR + DOUBLE PRECISION DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, DIMAG, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* + IF ( INFO.NE.0 ) RETURN + EPS = DLAMCH( 'Epsilon' ) + HUGEVAL = DLAMCH( 'Overflow' ) +* Force HUGEVAL to Inf + HUGEVAL = HUGEVAL * HUGEVAL +* Using HUGEVAL may lead to spurious underflows. + INCR_THRESH = DBLE( N ) * EPS + + IF ( LSAME ( UPLO, 'L' ) ) THEN + UPLO2 = ILAUPLO( 'L' ) + ELSE + UPLO2 = ILAUPLO( 'U' ) + ENDIF + + DO J = 1, NRHS + Y_PREC_STATE = EXTRA_RESIDUAL + IF ( Y_PREC_STATE .EQ. EXTRA_Y ) THEN + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + DXRAT = 0.0D+0 + DXRATMAX = 0.0D+0 + DZRAT = 0.0D+0 + DZRATMAX = 0.0D+0 + FINAL_DX_X = HUGEVAL + FINAL_DZ_Z = HUGEVAL + PREVNORMDX = HUGEVAL + PREV_DZ_Z = HUGEVAL + DZ_Z = HUGEVAL + DX_X = HUGEVAL + + X_STATE = WORKING_STATE + Z_STATE = UNSTABLE_STATE + INCR_PREC = .FALSE. + + DO CNT = 1, ITHRESH +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + IF ( Y_PREC_STATE .EQ. BASE_RESIDUAL ) THEN + CALL ZSYMV( UPLO, N, DCMPLX(-1.0D+0), A, LDA, Y(1,J), 1, + $ DCMPLX(1.0D+0), RES, 1 ) + ELSE IF ( Y_PREC_STATE .EQ. EXTRA_RESIDUAL ) THEN + CALL BLAS_ZSYMV_X( UPLO2, N, DCMPLX(-1.0D+0), A, LDA, + $ Y( 1, J ), 1, DCMPLX(1.0D+0), RES, 1, PREC_TYPE ) + ELSE + CALL BLAS_ZSYMV2_X(UPLO2, N, DCMPLX(-1.0D+0), A, LDA, + $ Y(1, J), Y_TAIL, 1, DCMPLX(1.0D+0), RES, 1, + $ PREC_TYPE) + END IF + +! XXX: RES is no longer needed. + CALL ZCOPY( N, RES, 1, DY, 1 ) + CALL ZSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, DY, N, INFO ) +* +* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. +* + NORMX = 0.0D+0 + NORMY = 0.0D+0 + NORMDX = 0.0D+0 + DZ_Z = 0.0D+0 + YMIN = HUGEVAL + + DO I = 1, N + YK = CABS1( Y( I, J ) ) + DYK = CABS1( DY( I ) ) + + IF ( YK .NE. 0.0D+0 ) THEN + DZ_Z = MAX( DZ_Z, DYK / YK ) + ELSE IF ( DYK .NE. 0.0D+0 ) THEN + DZ_Z = HUGEVAL + END IF + + YMIN = MIN( YMIN, YK ) + + NORMY = MAX( NORMY, YK ) + + IF ( COLEQU ) THEN + NORMX = MAX( NORMX, YK * C( I ) ) + NORMDX = MAX( NORMDX, DYK * C( I ) ) + ELSE + NORMX = NORMY + NORMDX = MAX( NORMDX, DYK ) + END IF + END DO + + IF ( NORMX .NE. 0.0D+0 ) THEN + DX_X = NORMDX / NORMX + ELSE IF ( NORMDX .EQ. 0.0D+0 ) THEN + DX_X = 0.0D+0 + ELSE + DX_X = HUGEVAL + END IF + + DXRAT = NORMDX / PREVNORMDX + DZRAT = DZ_Z / PREV_DZ_Z +* +* Check termination criteria. +* + IF ( YMIN*RCOND .LT. INCR_THRESH*NORMY + $ .AND. Y_PREC_STATE .LT. EXTRA_Y ) + $ INCR_PREC = .TRUE. + + IF ( X_STATE .EQ. NOPROG_STATE .AND. DXRAT .LE. RTHRESH ) + $ X_STATE = WORKING_STATE + IF ( X_STATE .EQ. WORKING_STATE ) THEN + IF ( DX_X .LE. EPS ) THEN + X_STATE = CONV_STATE + ELSE IF ( DXRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + X_STATE = NOPROG_STATE + END IF + ELSE + IF (DXRAT .GT. DXRATMAX) DXRATMAX = DXRAT + END IF + IF ( X_STATE .GT. WORKING_STATE ) FINAL_DX_X = DX_X + END IF + + IF ( Z_STATE .EQ. UNSTABLE_STATE .AND. DZ_Z .LE. DZ_UB ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. NOPROG_STATE .AND. DZRAT .LE. RTHRESH ) + $ Z_STATE = WORKING_STATE + IF ( Z_STATE .EQ. WORKING_STATE ) THEN + IF ( DZ_Z .LE. EPS ) THEN + Z_STATE = CONV_STATE + ELSE IF ( DZ_Z .GT. DZ_UB ) THEN + Z_STATE = UNSTABLE_STATE + DZRATMAX = 0.0D+0 + FINAL_DZ_Z = HUGEVAL + ELSE IF ( DZRAT .GT. RTHRESH ) THEN + IF ( Y_PREC_STATE .NE. EXTRA_Y ) THEN + INCR_PREC = .TRUE. + ELSE + Z_STATE = NOPROG_STATE + END IF + ELSE + IF ( DZRAT .GT. DZRATMAX ) DZRATMAX = DZRAT + END IF + IF ( Z_STATE .GT. WORKING_STATE ) FINAL_DZ_Z = DZ_Z + END IF + + IF ( X_STATE.NE.WORKING_STATE.AND. + $ ( IGNORE_CWISE.OR.Z_STATE.NE.WORKING_STATE ) ) + $ GOTO 666 + + IF ( INCR_PREC ) THEN + INCR_PREC = .FALSE. + Y_PREC_STATE = Y_PREC_STATE + 1 + DO I = 1, N + Y_TAIL( I ) = 0.0D+0 + END DO + END IF + + PREVNORMDX = NORMDX + PREV_DZ_Z = DZ_Z +* +* Update soluton. +* + IF ( Y_PREC_STATE .LT. EXTRA_Y ) THEN + CALL ZAXPY( N, DCMPLX(1.0D+0), DY, 1, Y(1,J), 1 ) + ELSE + CALL ZLA_WWADDW( N, Y(1,J), Y_TAIL, DY ) + END IF + + END DO +* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't EXIT. + 666 CONTINUE +* +* Set final_* when cnt hits ithresh. +* + IF ( X_STATE .EQ. WORKING_STATE ) FINAL_DX_X = DX_X + IF ( Z_STATE .EQ. WORKING_STATE ) FINAL_DZ_Z = DZ_Z +* +* Compute error bounds. +* + IF ( N_NORMS .GE. 1 ) THEN + ERRS_N( J, LA_LINRX_ERR_I ) = FINAL_DX_X / (1 - DXRATMAX) + END IF + IF ( N_NORMS .GE. 2 ) THEN + ERRS_C( J, LA_LINRX_ERR_I ) = FINAL_DZ_Z / (1 - DZRATMAX) + END IF +* +* Compute componentwise relative backward error from formula +* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) +* where abs(Z) is the componentwise absolute value of the matrix +* or vector Z. +* +* Compute residual RES = B_s - op(A_s) * Y, +* op(A) = A, A**T, or A**H depending on TRANS (and type). +* + CALL ZCOPY( N, B( 1, J ), 1, RES, 1 ) + CALL ZSYMV( UPLO, N, DCMPLX(-1.0D+0), A, LDA, Y(1,J), 1, + $ DCMPLX(1.0D+0), RES, 1 ) + + DO I = 1, N + AYB( I ) = CABS1( B( I, J ) ) + END DO +* +* Compute abs(op(A_s))*abs(Y) + abs(B_s). +* + CALL ZLA_SYAMV ( UPLO2, N, 1.0D+0, + $ A, LDA, Y(1, J), 1, 1.0D+0, AYB, 1 ) + + CALL ZLA_LIN_BERR ( N, N, 1, RES, AYB, BERR_OUT( J ) ) +* +* End of loop for each RHS. +* + END DO +* + RETURN + END diff --git a/SRC/zla_syrpvgrw.f b/SRC/zla_syrpvgrw.f new file mode 100644 index 00000000..2a358b3a --- /dev/null +++ b/SRC/zla_syrpvgrw.f @@ -0,0 +1,211 @@ + DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER*1 UPLO + INTEGER N, INFO, LDA, LDAF +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ) + DOUBLE PRECISION WORK( * ) + INTEGER IPIV( * ) +* .. +* .. Local Scalars .. + INTEGER NCOLS, I, J, K, KP + DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP + LOGICAL UPPER + COMPLEX*16 ZDUM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, REAL, DIMAG, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL LSAME, ZLASET + LOGICAL LSAME +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE ( ZDUM ) ) + ABS( DIMAG ( ZDUM ) ) +* .. +* .. Executable Statements .. +* + UPPER = LSAME( 'Upper', UPLO ) + IF ( INFO.EQ.0 ) THEN + IF ( UPPER ) THEN + NCOLS = 1 + ELSE + NCOLS = N + END IF + ELSE + NCOLS = INFO + END IF + + RPVGRW = 1.0D+0 + DO I = 1, 2*N + WORK( I ) = 0.0D+0 + END DO +* +* Find the max magnitude entry of each column of A. Compute the max +* for all N columns so we can apply the pivot permutation while +* looping below. Assume a full factorization is the common case. +* + IF ( UPPER ) THEN + DO J = 1, N + DO I = 1, J + WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + WORK( N+I ) = MAX( CABS1( A( I, J ) ), WORK( N+I ) ) + WORK( N+J ) = MAX( CABS1( A( I, J ) ), WORK( N+J ) ) + END DO + END DO + END IF +* +* Now find the max magnitude entry of each column of U or L. Also +* permute the magnitudes of A above so they're in the same order as +* the factor. +* +* The iteration orders and permutations were copied from zsytrs. +* Calls to SSWAP would be severe overkill. +* + IF ( UPPER ) THEN + K = N + DO WHILE ( K .LT. NCOLS .AND. K.GT.0 ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = 1, K + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K - 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K-1 ) + WORK( N+K-1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = 1, K-1 + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K-1 ) = + $ MAX( CABS1( AF( I, K-1 ) ), WORK( K-1 ) ) + END DO + WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K - 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .LE. N ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K + 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K + 2 + END IF + END DO + ELSE + K = 1 + DO WHILE ( K .LE. NCOLS ) + IF ( IPIV( K ).GT.0 ) THEN +! 1x1 pivot + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + DO I = K, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + END DO + K = K + 1 + ELSE +! 2x2 pivot + KP = -IPIV( K ) + TMP = WORK( N+K+1 ) + WORK( N+K+1 ) = WORK( N+KP ) + WORK( N+KP ) = TMP + DO I = K+1, N + WORK( K ) = MAX( CABS1( AF( I, K ) ), WORK( K ) ) + WORK( K+1 ) = + $ MAX( CABS1( AF( I, K+1 ) ), WORK( K+1 ) ) + END DO + WORK( K ) = MAX( CABS1( AF( K, K ) ), WORK( K ) ) + K = K + 2 + END IF + END DO + K = NCOLS + DO WHILE ( K .GE. 1 ) + IF ( IPIV( K ).GT.0 ) THEN + KP = IPIV( K ) + IF ( KP .NE. K ) THEN + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + END IF + K = K - 1 + ELSE + KP = -IPIV( K ) + TMP = WORK( N+K ) + WORK( N+K ) = WORK( N+KP ) + WORK( N+KP ) = TMP + K = K - 2 + ENDIF + END DO + END IF +* +* Compute the *inverse* of the max element growth factor. Dividing +* by zero would imply the largest entry of the factor's column is +* zero. Than can happen when either the column of A is zero or +* massive pivots made the factor underflow to zero. Neither counts +* as growth in itself, so simply ignore terms with zero +* denominators. +* + IF ( UPPER ) THEN + DO I = NCOLS, N + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + ELSE + DO I = 1, NCOLS + UMAX = WORK( I ) + AMAX = WORK( N+I ) + IF ( UMAX /= 0.0D+0 ) THEN + RPVGRW = MIN( AMAX / UMAX, RPVGRW ) + END IF + END DO + END IF + + ZLA_SYRPVGRW = RPVGRW + END FUNCTION diff --git a/SRC/zla_wwaddw.f b/SRC/zla_wwaddw.f new file mode 100644 index 00000000..cd4c7e78 --- /dev/null +++ b/SRC/zla_wwaddw.f @@ -0,0 +1,52 @@ + SUBROUTINE ZLA_WWADDW( N, X, Y, W ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER N +* .. +* .. Array Arguments .. + COMPLEX*16 X( * ), Y( * ), W( * ) +* .. +* +* Purpose +* ======= +* +* ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y). +* +* This works for all extant IBM's hex and binary floating point +* arithmetics, but not for decimal. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The length of vectors X, Y, and W. +* +* X, Y (input/output) COMPLEX*16 array, length N +* The doubled-single accumulation vector. +* +* W (input) COMPLEX*16 array, length N +* The vector to be added. +* .. +* .. Local Scalars .. + COMPLEX*16 S + INTEGER I +* .. +* .. Executable Statements .. + DO 10 I = 1, N + S = X(I) + W(I) + S = (S + S) - S + Y(I) = ((X(I) - S) + W(I)) + Y(I) + X(I) = S + 10 CONTINUE + RETURN + END diff --git a/SRC/zlabrd.f b/SRC/zlabrd.f index fb482c84..dc852f08 100644 --- a/SRC/zlabrd.f +++ b/SRC/zlabrd.f @@ -1,7 +1,7 @@ SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, $ LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacgv.f b/SRC/zlacgv.f index 0033e306..c6771500 100644 --- a/SRC/zlacgv.f +++ b/SRC/zlacgv.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACGV( N, X, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacn2.f b/SRC/zlacn2.f index 99f7ae35..90ec8c90 100644 --- a/SRC/zlacn2.f +++ b/SRC/zlacn2.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacon.f b/SRC/zlacon.f index 5773ef92..1d88debd 100644 --- a/SRC/zlacon.f +++ b/SRC/zlacon.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACON( N, V, X, EST, KASE ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacp2.f b/SRC/zlacp2.f index b42c30b3..fd36defd 100644 --- a/SRC/zlacp2.f +++ b/SRC/zlacp2.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacpy.f b/SRC/zlacpy.f index 8878311a..71fc6258 100644 --- a/SRC/zlacpy.f +++ b/SRC/zlacpy.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacrm.f b/SRC/zlacrm.f index b3f5a35d..4dda56bf 100644 --- a/SRC/zlacrm.f +++ b/SRC/zlacrm.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlacrt.f b/SRC/zlacrt.f index 7a0862cb..9f6d9cb0 100644 --- a/SRC/zlacrt.f +++ b/SRC/zlacrt.f @@ -1,6 +1,6 @@ SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zladiv.f b/SRC/zladiv.f index 4a12055e..d51bc293 100644 --- a/SRC/zladiv.f +++ b/SRC/zladiv.f @@ -1,6 +1,6 @@ COMPLEX*16 FUNCTION ZLADIV( X, Y ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaed0.f b/SRC/zlaed0.f index 92ad1f4c..e5926f46 100644 --- a/SRC/zlaed0.f +++ b/SRC/zlaed0.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaed7.f b/SRC/zlaed7.f index afe93bb6..24932b13 100644 --- a/SRC/zlaed7.f +++ b/SRC/zlaed7.f @@ -3,7 +3,7 @@ $ GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaed8.f b/SRC/zlaed8.f index 3d592d29..3e2dffbf 100644 --- a/SRC/zlaed8.f +++ b/SRC/zlaed8.f @@ -2,7 +2,7 @@ $ Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, $ GIVCOL, GIVNUM, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaein.f b/SRC/zlaein.f index eca2d8f9..711a0d8a 100644 --- a/SRC/zlaein.f +++ b/SRC/zlaein.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, $ EPS3, SMLNUM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaesy.f b/SRC/zlaesy.f index 43b76705..e9e0498d 100644 --- a/SRC/zlaesy.f +++ b/SRC/zlaesy.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaev2.f b/SRC/zlaev2.f index 0fa81cba..ba6bcf55 100644 --- a/SRC/zlaev2.f +++ b/SRC/zlaev2.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlag2c.f b/SRC/zlag2c.f index d47ca5ba..5850fc62 100644 --- a/SRC/zlag2c.f +++ b/SRC/zlag2c.f @@ -1,35 +1,28 @@ - SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO) + SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO ) * -* -- LAPACK PROTOTYPE auxilary routine (version 3.1.1) -- +* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. -* January 2007 -* -* .. -* .. WARNING: PROTOTYPE .. -* This is an LAPACK PROTOTYPE routine which means that the -* interface of this routine is likely to be changed in the future -* based on community feedback. +* August 2007 * * .. * .. Scalar Arguments .. - INTEGER INFO,LDA,LDSA,M,N + INTEGER INFO, LDA, LDSA, M, N * .. * .. Array Arguments .. - COMPLEX SA(LDSA,*) - COMPLEX*16 A(LDA,*) + COMPLEX SA( LDSA, * ) + COMPLEX*16 A( LDA, * ) * .. * * Purpose * ======= * -* ZLAG2C converts a DOUBLE PRECISION COMPLEX matrix, SA, to a SINGLE -* PRECISION COMPLEX matrix, A. +* ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A. * * RMAX is the overflow for the SINGLE PRECISION arithmetic * ZLAG2C checks that all the entries of A are between -RMAX and * RMAX. If not the convertion is aborted and a flag is raised. * -* This is a helper routine so there is no argument checking. +* This is an auxiliary routine so there is no argument checking. * * Arguments * ========= @@ -40,52 +33,55 @@ * N (input) INTEGER * The number of columns of the matrix A. N >= 0. * -* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* A (input) COMPLEX*16 array, dimension (LDA,N) * On entry, the M-by-N coefficient matrix A. * * LDA (input) INTEGER * The leading dimension of the array A. LDA >= max(1,M). * -* SA (output) REAL array, dimension (LDSA,N) -* On exit, if INFO=0, the M-by-N coefficient matrix SA. +* SA (output) COMPLEX array, dimension (LDSA,N) +* On exit, if INFO=0, the M-by-N coefficient matrix SA; if +* INFO>0, the content of SA is unspecified. * * LDSA (input) INTEGER * The leading dimension of the array SA. LDSA >= max(1,M). * * INFO (output) INTEGER -* = 0: successful exit -* > 0: if INFO = k, the (i,j) entry of the matrix A has -* overflowed when moving from DOUBLE PRECISION to SINGLE -* k is given by k = (i-1)*LDA+j +* = 0: successful exit. +* = 1: an entry of the matrix A is greater than the SINGLE +* PRECISION overflow threshold, in this case, the content +* of SA in exit is unspecified. * * ========= * * .. Local Scalars .. - INTEGER I,J - DOUBLE PRECISION RMAX + INTEGER I, J + DOUBLE PRECISION RMAX * .. * .. Intrinsic Functions .. - INTRINSIC DBLE, DIMAG + INTRINSIC DBLE, DIMAG * .. * .. External Functions .. - REAL SLAMCH - EXTERNAL SLAMCH + REAL SLAMCH + EXTERNAL SLAMCH * .. * .. Executable Statements .. * - RMAX = SLAMCH('O') - DO 20 J = 1,N - DO 30 I = 1,M - IF ((DBLE(A(I,J)).LT.-RMAX) .OR. (DBLE(A(I,J)).GT.RMAX) - $ .OR. (DIMAG(A(I,J)).LT.-RMAX) .OR. (DIMAG(A(I,J)).GT.RMAX)) - $ THEN - INFO = (I-1)*LDA + J - GO TO 10 - END IF - SA(I,J) = A(I,J) - 30 CONTINUE + RMAX = SLAMCH( 'O' ) + DO 20 J = 1, N + DO 10 I = 1, M + IF( ( DBLE( A( I, J ) ).LT.-RMAX ) .OR. + + ( DBLE( A( I, J ) ).GT.RMAX ) .OR. + + ( DIMAG( A( I, J ) ).LT.-RMAX ) .OR. + + ( DIMAG( A( I, J ) ).GT.RMAX ) ) THEN + INFO = 1 + GO TO 30 + END IF + SA( I, J ) = A( I, J ) + 10 CONTINUE 20 CONTINUE - 10 CONTINUE + INFO = 0 + 30 CONTINUE RETURN * * End of ZLAG2C diff --git a/SRC/zlags2.f b/SRC/zlags2.f index 293f75e4..762596ae 100644 --- a/SRC/zlags2.f +++ b/SRC/zlags2.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, $ SNV, CSQ, SNQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlagtm.f b/SRC/zlagtm.f index eb846530..7e923a2d 100644 --- a/SRC/zlagtm.f +++ b/SRC/zlagtm.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, $ B, LDB ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlahef.f b/SRC/zlahef.f index 3b1041ff..0079897e 100644 --- a/SRC/zlahef.f +++ b/SRC/zlahef.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlahqr.f b/SRC/zlahqr.f index 9ce9be19..d6216d98 100644 --- a/SRC/zlahqr.f +++ b/SRC/zlahqr.f @@ -1,8 +1,8 @@ SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -110,11 +110,10 @@ * * 12-04 Further modifications by * Ralph Byers, University of Kansas, USA -* -* This is a modified version of ZLAHQR from LAPACK version 3.0. -* It is (1) more robust against overflow and underflow and -* (2) adopts the more conservative Ahues & Tisseur stopping -* criterion (LAWN 122, 1997). +* This is a modified version of ZLAHQR from LAPACK version 3.0. +* It is (1) more robust against overflow and underflow and +* (2) adopts the more conservative Ahues & Tisseur stopping +* criterion (LAWN 122, 1997). * * ========================================================= * @@ -177,6 +176,13 @@ IF( ILO.LE.IHI-2 ) $ H( IHI, IHI-2 ) = ZERO * ==== ensure that subdiagonal entries are real ==== + IF( WANTT ) THEN + JLO = 1 + JHI = N + ELSE + JLO = ILO + JHI = IHI + END IF DO 20 I = ILO + 1, IHI IF( DIMAG( H( I, I-1 ) ).NE.RZERO ) THEN * ==== The following redundant normalization @@ -185,13 +191,6 @@ SC = H( I, I-1 ) / CABS1( H( I, I-1 ) ) SC = DCONJG( SC ) / ABS( SC ) H( I, I-1 ) = ABS( H( I, I-1 ) ) - IF( WANTT ) THEN - JLO = 1 - JHI = N - ELSE - JLO = ILO - JHI = IHI - END IF CALL ZSCAL( JHI-I+1, SC, H( I, I ), LDH ) CALL ZSCAL( MIN( JHI, I+1 )-JLO+1, DCONJG( SC ), $ H( JLO, I ), 1 ) @@ -289,7 +288,13 @@ I2 = I END IF * - IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN + IF( ITS.EQ.10 ) THEN +* +* Exceptional shift. +* + S = DAT1*ABS( DBLE( H( L+1, L ) ) ) + T = S + H( L, L ) + ELSE IF( ITS.EQ.20 ) THEN * * Exceptional shift. * @@ -326,13 +331,13 @@ H11 = H( M, M ) H22 = H( M+1, M+1 ) H11S = H11 - T - H21 = H( M+1, M ) + H21 = DBLE( H( M+1, M ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S V( 1 ) = H11S V( 2 ) = H21 - H10 = H( M, M-1 ) + H10 = DBLE( H( M, M-1 ) ) IF( ABS( H10 )*ABS( H21 ).LE.ULP* $ ( CABS1( H11S )*( CABS1( H11 )+CABS1( H22 ) ) ) ) $ GO TO 70 @@ -340,7 +345,7 @@ H11 = H( L, L ) H22 = H( L+1, L+1 ) H11S = H11 - T - H21 = H( L+1, L ) + H21 = DBLE( H( L+1, L ) ) S = CABS1( H11S ) + ABS( H21 ) H11S = H11S / S H21 = H21 / S diff --git a/SRC/zlahr2.f b/SRC/zlahr2.f index f3cb5515..8822ed69 100644 --- a/SRC/zlahr2.f +++ b/SRC/zlahr2.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlahrd.f b/SRC/zlahrd.f index e7eb9de9..296a5543 100644 --- a/SRC/zlahrd.f +++ b/SRC/zlahrd.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaic1.f b/SRC/zlaic1.f index 589f0889..9cc49fac 100644 --- a/SRC/zlaic1.f +++ b/SRC/zlaic1.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlals0.f b/SRC/zlals0.f index 9d419612..a39d4aac 100644 --- a/SRC/zlals0.f +++ b/SRC/zlals0.f @@ -2,7 +2,7 @@ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, $ POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlalsa.f b/SRC/zlalsa.f index a1516bc3..1ef48839 100644 --- a/SRC/zlalsa.f +++ b/SRC/zlalsa.f @@ -3,7 +3,7 @@ $ GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlalsd.f b/SRC/zlalsd.f index 8f01f7b2..cc358023 100644 --- a/SRC/zlalsd.f +++ b/SRC/zlalsd.f @@ -1,7 +1,7 @@ SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, $ RANK, WORK, RWORK, IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlangb.f b/SRC/zlangb.f index 99dd3beb..ce642754 100644 --- a/SRC/zlangb.f +++ b/SRC/zlangb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlange.f b/SRC/zlange.f index 36cecbdc..ae2c183b 100644 --- a/SRC/zlange.f +++ b/SRC/zlange.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlangt.f b/SRC/zlangt.f index d2a25db5..12d96c82 100644 --- a/SRC/zlangt.f +++ b/SRC/zlangt.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlanhb.f b/SRC/zlanhb.f index 1fd88397..9c2668a1 100644 --- a/SRC/zlanhb.f +++ b/SRC/zlanhb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlanhe.f b/SRC/zlanhe.f index 86e57fcd..dbdf2c65 100644 --- a/SRC/zlanhe.f +++ b/SRC/zlanhe.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlanhf.f b/SRC/zlanhf.f new file mode 100644 index 00000000..40409936 --- /dev/null +++ b/SRC/zlanhf.f @@ -0,0 +1,1358 @@ + DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER NORM, TRANSR, UPLO + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION WORK( 0: * ) + COMPLEX*16 A( 0: * ) +* .. +* +* Purpose +* ======= +* +* ZLANHF returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* complex Hermitian matrix A in RFP format. +* +* Description +* =========== +* +* ZLANHF returns the value +* +* ZLANHF = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER +* Specifies the value to be returned in ZLANHF as described +* above. +* +* TRANSR (input) CHARACTER +* Specifies whether the RFP format of A is normal or +* conjugate-transposed format. +* = 'N': RFP format is Normal +* = 'C': RFP format is Conjugate-transposed +* +* UPLO (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' RFP A came from an upper triangular +* matrix +* +* UPLO = 'L' or 'l' RFP A came from a lower triangular +* matrix +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, ZLANHF is +* set to zero. +* +* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); +* On entry, the matrix A in RFP Format. +* RFP Format is described by TRANSR, UPLO and N as follows: +* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A +* as defined when TRANSR = 'N'. The contents of RFP A are +* defined by UPLO as follows: If UPLO = 'U' the RFP A +* contains the ( N*(N+1)/2 ) elements of upper packed A +* either in normal or conjugate-transpose Format. If +* UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements +* of lower packed A either in normal or conjugate-transpose +* Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When +* TRANSR is 'N' the LDA is N+1 when N is even and is N when +* is odd. See the Note below for more details. +* Unchanged on exit. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), +* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +* WORK is not referenced. +* +* Note: +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, IFM, ILU, NOE, N1, K, L, LDA + DOUBLE PRECISION SCALE, S, VALUE, AA +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + ZLANHF = ZERO + RETURN + END IF +* +* set noe = 1 if n is odd. if n is even set noe=0 +* + NOE = 1 + IF( MOD( N, 2 ).EQ.0 ) + + NOE = 0 +* +* set ifm = 0 when form='C' or 'c' and 1 otherwise +* + IFM = 1 + IF( LSAME( TRANSR, 'C' ) ) + + IFM = 0 +* +* set ilu = 0 when uplo='U or 'u' and 1 otherwise +* + ILU = 1 + IF( LSAME( UPLO, 'U' ) ) + + ILU = 0 +* +* set lda = (n+1)/2 when ifm = 0 +* set lda = n when ifm = 1 and noe = 1 +* set lda = n+1 when ifm = 1 and noe = 0 +* + IF( IFM.EQ.1 ) THEN + IF( NOE.EQ.1 ) THEN + LDA = N + ELSE +* noe=0 + LDA = N + 1 + END IF + ELSE +* ifm=0 + LDA = ( N+1 ) / 2 + END IF +* + IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + K = ( N+1 ) / 2 + VALUE = ZERO + IF( NOE.EQ.1 ) THEN +* n is odd & n = k + k - 1 + IF( IFM.EQ.1 ) THEN +* A is n by k + IF( ILU.EQ.1 ) THEN +* uplo ='L' + J = 0 +* -> L(0,0) + VALUE = MAX( VALUE, ABS( DBLE( A( J+J*LDA ) ) ) ) + DO I = 1, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = 1, K - 1 + DO I = 0, J - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - 1 +* L(k+j,k+j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = J +* -> L(j,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = J + 1, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 2 + DO I = 0, K + J - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K + J - 1 +* -> U(i,i) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = I + 1 +* =k+j; i -> U(j,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = K + J + 1, N - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + DO I = 0, N - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) +* j=k-1 + END DO +* i=n-1 -> U(n-1,n-1) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + END IF + ELSE +* xpose case; A is k by n + IF( ILU.EQ.1 ) THEN +* uplo ='L' + DO J = 0, K - 2 + DO I = 0, J - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J +* L(i,i) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = J + 1 +* L(j+k,j+k) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = J + 2, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K - 1 + DO I = 0, K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K - 1 +* -> L(i,i) is at A(i,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO J = K, N - 1 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 2 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K - 1 +* -> U(j,j) is at A(0,j) + VALUE = MAX( VALUE, ABS( DBLE( A( 0+J*LDA ) ) ) ) + DO I = 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = K, N - 1 + DO I = 0, J - K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - K +* -> U(i,i) at A(i,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = J - K + 1 +* U(j,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = J - K + 2, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + END IF + END IF + ELSE +* n is even & k = n/2 + IF( IFM.EQ.1 ) THEN +* A is n+1 by k + IF( ILU.EQ.1 ) THEN +* uplo ='L' + J = 0 +* -> L(k,k) & j=1 -> L(0,0) + VALUE = MAX( VALUE, ABS( DBLE( A( J+J*LDA ) ) ) ) + VALUE = MAX( VALUE, ABS( DBLE( A( J+1+J*LDA ) ) ) ) + DO I = 2, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = 1, K - 1 + DO I = 0, J - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J +* L(k+j,k+j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = J + 1 +* -> L(j,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = J + 2, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 2 + DO I = 0, K + J - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K + J +* -> U(i,i) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = I + 1 +* =k+j+1; i -> U(j,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = K + J + 2, N + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + DO I = 0, N - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) +* j=k-1 + END DO +* i=n-1 -> U(n-1,n-1) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = N +* -> U(k-1,k-1) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + END IF + ELSE +* xpose case; A is k by n+1 + IF( ILU.EQ.1 ) THEN +* uplo ='L' + J = 0 +* -> L(k,k) at A(0,0) + VALUE = MAX( VALUE, ABS( DBLE( A( J+J*LDA ) ) ) ) + DO I = 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = 1, K - 1 + DO I = 0, J - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - 1 +* L(i,i) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = J +* L(j+k,j+k) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = J + 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K + DO I = 0, K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K - 1 +* -> L(i,i) is at A(i,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO J = K + 1, N + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + ELSE +* uplo = 'U' + DO J = 0, K - 1 + DO I = 0, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = K +* -> U(j,j) is at A(0,j) + VALUE = MAX( VALUE, ABS( DBLE( A( 0+J*LDA ) ) ) ) + DO I = 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + DO J = K + 1, N - 1 + DO I = 0, J - K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = J - K - 1 +* -> U(i,i) at A(i,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + I = J - K +* U(j,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + DO I = J - K + 1, K - 1 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + END DO + J = N + DO I = 0, K - 2 + VALUE = MAX( VALUE, ABS( A( I+J*LDA ) ) ) + END DO + I = K - 1 +* U(k,k) at A(i,j) + VALUE = MAX( VALUE, ABS( DBLE( A( I+J*LDA ) ) ) ) + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + + ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is Hermitian). +* + IF( IFM.EQ.1 ) THEN +* A is 'N' + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd & A is n by (n+1)/2 + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + IF( I.EQ.K+K ) + + GO TO 10 + I = I + 1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + 10 CONTINUE + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 & uplo = 'L' + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + IF( J.GT.0 ) THEN + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + END IF + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even & A is n+1 by k = n/2 + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + DO I = 0, K - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K + J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(i,j+k) + S = S + AA + WORK( I ) = WORK( I ) + AA + END DO + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + WORK( J+K ) = S + AA + I = I + 1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = WORK( J ) + AA + S = ZERO + DO L = J + 1, K - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu = 1 & uplo = 'L' + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = K - 1, 0, -1 + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(j+k,i+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + AA + END DO + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j+k,j+k) + S = S + AA + WORK( I+K ) = WORK( I+K ) + S +* i=j + I = I + 1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* -> A(j,j) + WORK( J ) = AA + S = ZERO + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* -> A(l,j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + ELSE +* ifm=0 + K = N / 2 + IF( NOE.EQ.1 ) THEN +* n is odd & A is (n+1)/2 by n + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + N1 = K +* n/2 + K = K + 1 +* k is the row size and lda + DO I = N1, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, N1 - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,n1+i) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=n1=k-1 is special + S = ABS( DBLE( A( 0+J*LDA ) ) ) +* A(k-1,k-1) + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k-1,i+n1) + WORK( I+N1 ) = WORK( I+N1 ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K, N - 1 + S = ZERO + DO I = 0, J - K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-k + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* A(j-k,j-k) + S = S + AA + WORK( J-K ) = WORK( J-K ) + S + I = I + 1 + S = ABS( DBLE( A( I+J*LDA ) ) ) +* A(j,j) + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 & uplo = 'L' + K = K + 1 +* k=(n+1)/2 for n odd and ilu=1 + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 2 +* process + S = ZERO + DO I = 0, J - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* i=j so process of A(j,j) + S = S + AA + WORK( J ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( DBLE( A( I+J*LDA ) ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k-1 is special :process col A(k-1,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K, N - 1 +* process col j of A = A(j,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + ELSE +* n is even & A is k=n/2 by n+1 + IF( ILU.EQ.0 ) THEN +* uplo = 'U' + DO I = K, N - 1 + WORK( I ) = ZERO + END DO + DO J = 0, K - 1 + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,i+k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = S + END DO +* j=k + AA = ABS( DBLE( A( 0+J*LDA ) ) ) +* A(k,k) + S = AA + DO I = 1, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(k,k+i) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + DO J = K + 1, N - 1 + S = ZERO + DO I = 0, J - 2 - K + AA = ABS( A( I+J*LDA ) ) +* A(i,j-k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=j-1-k + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* A(j-k-1,j-k-1) + S = S + AA + WORK( J-K-1 ) = WORK( J-K-1 ) + S + I = I + 1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* A(j,j) + S = AA + DO L = J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(j,l) + WORK( L ) = WORK( L ) + AA + S = S + AA + END DO + WORK( J ) = WORK( J ) + S + END DO +* j=n + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(i,k-1) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* i=k-1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = WORK( I ) + S + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + ELSE +* ilu=1 & uplo = 'L' + DO I = K, N - 1 + WORK( I ) = ZERO + END DO +* j=0 is special :process col A(k:n-1,k) + S = ABS( DBLE( A( 0 ) ) ) +* A(k,k) + DO I = 1, K - 1 + AA = ABS( A( I ) ) +* A(k+i,k) + WORK( I+K ) = WORK( I+K ) + AA + S = S + AA + END DO + WORK( K ) = WORK( K ) + S + DO J = 1, K - 1 +* process + S = ZERO + DO I = 0, J - 2 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* i=j-1 so process of A(j-1,j-1) + S = S + AA + WORK( J-1 ) = S +* is initialised here + I = I + 1 +* i=j process A(j+k,j+k) + AA = ABS( DBLE( A( I+J*LDA ) ) ) + S = AA + DO L = K + J + 1, N - 1 + I = I + 1 + AA = ABS( A( I+J*LDA ) ) +* A(l,k+j) + S = S + AA + WORK( L ) = WORK( L ) + AA + END DO + WORK( K+J ) = WORK( K+J ) + S + END DO +* j=k is special :process col A(k,0:k-1) + S = ZERO + DO I = 0, K - 2 + AA = ABS( A( I+J*LDA ) ) +* A(k,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO +* +* i=k-1 + AA = ABS( DBLE( A( I+J*LDA ) ) ) +* A(k-1,k-1) + S = S + AA + WORK( I ) = S +* done with col j=k+1 + DO J = K + 1, N +* +* process col j-1 of A = A(j-1,0:k-1) + S = ZERO + DO I = 0, K - 1 + AA = ABS( A( I+J*LDA ) ) +* A(j-1,i) + WORK( I ) = WORK( I ) + AA + S = S + AA + END DO + WORK( J-1 ) = WORK( J-1 ) + S + END DO + I = IDAMAX( N, WORK, 1 ) + VALUE = WORK( I-1 ) + END IF + END IF + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + K = ( N+1 ) / 2 + SCALE = ZERO + S = ONE + IF( NOE.EQ.1 ) THEN +* n is odd + IF( IFM.EQ.1 ) THEN +* A is normal & A is n by k + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 3 + CALL ZLASSQ( K-J-2, A( K+J+1+J*LDA ), 1, SCALE, S ) +* L at A(k,0) + END DO + DO J = 0, K - 1 + CALL ZLASSQ( K+J-1, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = K - 1 +* -> U(k,k) at A(k-1,0) + DO I = 0, K - 2 + AA = DBLE( A( L ) ) +* U(k+i,k+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* U(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + AA = DBLE( A( L ) ) +* U(n-1,n-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL ZLASSQ( N-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* trap L at A(0,0) + END DO + DO J = 1, K - 2 + CALL ZLASSQ( J, A( 0+( 1+J )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + S = S + S +* double s for the off diagonal elements + AA = DBLE( A( 0 ) ) +* L(0,0) at A(0,0) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = LDA +* -> L(k,k) at A(0,1) + DO I = 1, K - 1 + AA = DBLE( A( L ) ) +* L(k-1+i,k-1+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + END IF + ELSE +* A is xpose & A is k by n + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 2 + CALL ZLASSQ( J, A( 0+( K+J )*LDA ), 1, SCALE, S ) +* U at A(0,k) + END DO + DO J = 0, K - 2 + CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL ZLASSQ( K-J-1, A( J+1+( J+K-1 )*LDA ), 1, + + SCALE, S ) +* L at A(0,k-1) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 + K*LDA - LDA +* -> U(k-1,k-1) at A(0,k-1) + AA = DBLE( A( L ) ) +* U(k-1,k-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA +* -> U(0,0) at A(0,k) + DO J = K, N - 1 + AA = DBLE( A( L ) ) +* -> U(j-k,j-k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* -> U(j,j) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + ELSE +* A' is lower + DO J = 1, K - 1 + CALL ZLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + DO J = K, N - 1 + CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k-1 rect. at A(0,k) + END DO + DO J = 0, K - 3 + CALL ZLASSQ( K-J-2, A( J+2+J*LDA ), 1, SCALE, S ) +* L at A(1,0) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 +* -> L(0,0) at A(0,0) + DO I = 0, K - 2 + AA = DBLE( A( L ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* L(k+i,k+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO +* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1) + AA = DBLE( A( L ) ) +* L(k-1,k-1) at A(k-1,k-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + END IF + END IF + ELSE +* n is even + IF( IFM.EQ.1 ) THEN +* A is normal + IF( ILU.EQ.0 ) THEN +* A is upper + DO J = 0, K - 2 + CALL ZLASSQ( K-J-1, A( K+J+2+J*LDA ), 1, SCALE, S ) +* L at A(k+1,0) + END DO + DO J = 0, K - 1 + CALL ZLASSQ( K+J, A( 0+J*LDA ), 1, SCALE, S ) +* trap U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = K +* -> U(k,k) at A(k,0) + DO I = 0, K - 1 + AA = DBLE( A( L ) ) +* U(k+i,k+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* U(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + ELSE +* ilu=1 & A is lower + DO J = 0, K - 1 + CALL ZLASSQ( N-J-1, A( J+2+J*LDA ), 1, SCALE, S ) +* trap L at A(1,0) + END DO + DO J = 1, K - 1 + CALL ZLASSQ( J, A( 0+J*LDA ), 1, SCALE, S ) +* U at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 +* -> L(k,k) at A(0,0) + DO I = 0, K - 1 + AA = DBLE( A( L ) ) +* L(k-1+i,k-1+i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO + END IF + ELSE +* A is xpose + IF( ILU.EQ.0 ) THEN +* A' is upper + DO J = 1, K - 1 + CALL ZLASSQ( J, A( 0+( K+1+J )*LDA ), 1, SCALE, S ) +* U at A(0,k+1) + END DO + DO J = 0, K - 1 + CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,0) + END DO + DO J = 0, K - 2 + CALL ZLASSQ( K-J-1, A( J+1+( J+K )*LDA ), 1, SCALE, + + S ) +* L at A(0,k) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 + K*LDA +* -> U(k,k) at A(0,k) + AA = DBLE( A( L ) ) +* U(k,k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA +* -> U(0,0) at A(0,k+1) + DO J = K + 1, N - 1 + AA = DBLE( A( L ) ) +* -> U(j-k-1,j-k-1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* -> U(j,j) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO +* L=k-1+n*lda +* -> U(k-1,k-1) at A(k-1,n) + AA = DBLE( A( L ) ) +* U(k,k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + ELSE +* A' is lower + DO J = 1, K - 1 + CALL ZLASSQ( J, A( 0+( J+1 )*LDA ), 1, SCALE, S ) +* U at A(0,1) + END DO + DO J = K + 1, N + CALL ZLASSQ( K, A( 0+J*LDA ), 1, SCALE, S ) +* k by k rect. at A(0,k+1) + END DO + DO J = 0, K - 2 + CALL ZLASSQ( K-J-1, A( J+1+J*LDA ), 1, SCALE, S ) +* L at A(0,0) + END DO + S = S + S +* double s for the off diagonal elements + L = 0 +* -> L(k,k) at A(0,0) + AA = DBLE( A( L ) ) +* L(k,k) at A(0,0) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = LDA +* -> L(0,0) at A(0,1) + DO I = 0, K - 2 + AA = DBLE( A( L ) ) +* L(i,i) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + AA = DBLE( A( L+1 ) ) +* L(k+i+1,k+i+1) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + L = L + LDA + 1 + END DO +* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k) + AA = DBLE( A( L ) ) +* L(k-1,k-1) at A(k-1,k) + IF( AA.NE.ZERO ) THEN + IF( SCALE.LT.AA ) THEN + S = ONE + S*( SCALE / AA )**2 + SCALE = AA + ELSE + S = S + ( AA / SCALE )**2 + END IF + END IF + END IF + END IF + END IF + VALUE = SCALE*SQRT( S ) + END IF +* + ZLANHF = VALUE + RETURN +* +* End of ZLANHF +* + END diff --git a/SRC/zlanhp.f b/SRC/zlanhp.f index c0ff3b94..7d4e96cb 100644 --- a/SRC/zlanhp.f +++ b/SRC/zlanhp.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlanhs.f b/SRC/zlanhs.f index d7b187a5..bae6b875 100644 --- a/SRC/zlanhs.f +++ b/SRC/zlanhs.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlanht.f b/SRC/zlanht.f index 3cccfdf0..152161b2 100644 --- a/SRC/zlanht.f +++ b/SRC/zlanht.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlansb.f b/SRC/zlansb.f index 944c1087..829b9a06 100644 --- a/SRC/zlansb.f +++ b/SRC/zlansb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlansp.f b/SRC/zlansp.f index bdbcbcda..e1edeed1 100644 --- a/SRC/zlansp.f +++ b/SRC/zlansp.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlansy.f b/SRC/zlansy.f index aaf4619a..571a60d6 100644 --- a/SRC/zlansy.f +++ b/SRC/zlansy.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlantb.f b/SRC/zlantb.f index 52488b0a..77a9b4a4 100644 --- a/SRC/zlantb.f +++ b/SRC/zlantb.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, $ LDAB, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlantp.f b/SRC/zlantp.f index 628c406c..9558576b 100644 --- a/SRC/zlantp.f +++ b/SRC/zlantp.f @@ -1,6 +1,6 @@ DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlantr.f b/SRC/zlantr.f index f2f37ca4..d9b23763 100644 --- a/SRC/zlantr.f +++ b/SRC/zlantr.f @@ -1,7 +1,7 @@ DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlapll.f b/SRC/zlapll.f index b55bd912..47f3f59c 100644 --- a/SRC/zlapll.f +++ b/SRC/zlapll.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlapmt.f b/SRC/zlapmt.f index ee159ed0..ae0c68eb 100644 --- a/SRC/zlapmt.f +++ b/SRC/zlapmt.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqgb.f b/SRC/zlaqgb.f index 9c0afcda..f2f7e048 100644 --- a/SRC/zlaqgb.f +++ b/SRC/zlaqgb.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqge.f b/SRC/zlaqge.f index 0e677146..d2564929 100644 --- a/SRC/zlaqge.f +++ b/SRC/zlaqge.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, $ EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqhb.f b/SRC/zlaqhb.f index 77c6a83e..65c90f36 100644 --- a/SRC/zlaqhb.f +++ b/SRC/zlaqhb.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqhe.f b/SRC/zlaqhe.f index c508032b..2a1a1b89 100644 --- a/SRC/zlaqhe.f +++ b/SRC/zlaqhe.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqhp.f b/SRC/zlaqhp.f index 5e2dfa0d..16b70761 100644 --- a/SRC/zlaqhp.f +++ b/SRC/zlaqhp.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqp2.f b/SRC/zlaqp2.f index 3acb25ec..ed4e716c 100644 --- a/SRC/zlaqp2.f +++ b/SRC/zlaqp2.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqps.f b/SRC/zlaqps.f index 754c1704..549f00b1 100644 --- a/SRC/zlaqps.f +++ b/SRC/zlaqps.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, $ VN2, AUXV, F, LDF ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqr0.f b/SRC/zlaqr0.f index 2a35a725..464d40f1 100644 --- a/SRC/zlaqr0.f +++ b/SRC/zlaqr0.f @@ -1,8 +1,8 @@ SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -156,20 +156,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== DOUBLE PRECISION WILK1 PARAMETER ( WILK1 = 0.75d0 ) COMPLEX*16 ZERO, ONE @@ -183,9 +186,9 @@ DOUBLE PRECISION S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -218,24 +221,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use ZLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use ZLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -250,6 +238,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -259,7 +260,6 @@ NWR = ILAENV( 13, 'ZLAQR0', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -310,6 +310,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -348,50 +349,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. - $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/zlaqr1.f b/SRC/zlaqr1.f index b8c1c3d4..ba62ccd9 100644 --- a/SRC/zlaqr1.f +++ b/SRC/zlaqr1.f @@ -1,7 +1,7 @@ SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -54,8 +54,8 @@ PARAMETER ( RZERO = 0.0d0 ) * .. * .. Local Scalars .. - COMPLEX*16 CDUM - DOUBLE PRECISION H21S, H31S, S + COMPLEX*16 CDUM, H21S, H31S + DOUBLE PRECISION S * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DIMAG diff --git a/SRC/zlaqr2.f b/SRC/zlaqr2.f index 0add51ae..7a6fbc05 100644 --- a/SRC/zlaqr2.f +++ b/SRC/zlaqr2.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -81,7 +81,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the unitary * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -152,7 +152,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), @@ -172,7 +172,7 @@ * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, - $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR + $ ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN @@ -197,9 +197,10 @@ CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to ZUNGHR ==== +* ==== Workspace query call to ZUNMHR ==== * - CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Optimal workspace ==== @@ -218,6 +219,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -256,6 +258,7 @@ IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -291,7 +294,7 @@ NS = NS - 1 ELSE * -* ==== One undflatable eigenvalue. Move it up out of the +* ==== One undeflatable eigenvalue. Move it up out of the * . way. (ZTREXC can not fail in this case.) ==== * IFST = NS @@ -364,18 +367,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of ZUNGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/zlaqr3.f b/SRC/zlaqr3.f index e9bf393a..742894bf 100644 --- a/SRC/zlaqr3.f +++ b/SRC/zlaqr3.f @@ -2,8 +2,8 @@ $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -77,7 +77,7 @@ * Specify the rows of Z to which transformations must be * applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N. * -* Z (input/output) COMPLEX*16 array, dimension (LDZ,IHI) +* Z (input/output) COMPLEX*16 array, dimension (LDZ,N) * IF WANTZ is .TRUE., then on output, the unitary * similarity transformation mentioned above has been * accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right. @@ -148,7 +148,7 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ================================================================== +* ================================================================ * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), @@ -170,7 +170,7 @@ * .. * .. External Subroutines .. EXTERNAL DLABAD, ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, - $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNGHR + $ ZLAQR4, ZLARF, ZLARFG, ZLASET, ZTREXC, ZUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN @@ -195,9 +195,10 @@ CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) LWK1 = INT( WORK( 1 ) ) * -* ==== Workspace query call to ZUNGHR ==== +* ==== Workspace query call to ZUNMHR ==== * - CALL ZUNGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * * ==== Workspace query call to ZLAQR4 ==== @@ -222,6 +223,7 @@ * ... for an empty active block ... ==== NS = 0 ND = 0 + WORK( 1 ) = ONE IF( KTOP.GT.KBOT ) $ RETURN * ... nor for an empty deflation window. ==== @@ -255,12 +257,12 @@ ND = 0 IF( CABS1( S ).LE.MAX( SMLNUM, ULP*CABS1( H( KWTOP, $ KWTOP ) ) ) ) THEN - NS = 0 ND = 1 IF( KWTOP.GT.KTOP ) $ H( KWTOP, KWTOP-1 ) = ZERO END IF + WORK( 1 ) = ONE RETURN END IF * @@ -302,7 +304,7 @@ NS = NS - 1 ELSE * -* ==== One undflatable eigenvalue. Move it up out of the +* ==== One undeflatable eigenvalue. Move it up out of the * . way. (ZTREXC can not fail in this case.) ==== * IFST = NS @@ -375,18 +377,11 @@ $ LDH+1 ) * * ==== Accumulate orthogonal matrix in order update -* . H and Z, if requested. (A modified version -* . of ZUNGHR that accumulates block Householder -* . transformations into V directly might be -* . marginally more efficient than the following.) ==== +* . H and Z, if requested. ==== * - IF( NS.GT.1 .AND. S.NE.ZERO ) THEN - CALL ZUNGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), - $ LWORK-JW, INFO ) - CALL ZGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO, - $ WV, LDWV ) - CALL ZLACPY( 'A', JW, NS, WV, LDWV, V, LDV ) - END IF + IF( NS.GT.1 .AND. S.NE.ZERO ) + $ CALL ZUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== * diff --git a/SRC/zlaqr4.f b/SRC/zlaqr4.f index eef7f00a..b5209e8d 100644 --- a/SRC/zlaqr4.f +++ b/SRC/zlaqr4.f @@ -1,8 +1,8 @@ SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, $ IHIZ, Z, LDZ, WORK, LWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -163,20 +163,23 @@ * ==== Matrices of order NTINY or smaller must be processed by * . ZLAHQR because of insufficient subdiagonal scratch space. * . (This is a hard limit.) ==== + INTEGER NTINY + PARAMETER ( NTINY = 11 ) * * ==== Exceptional deflation windows: try to cure rare -* . slow convergence by increasing the size of the -* . deflation window after KEXNW iterations. ===== +* . slow convergence by varying the size of the +* . deflation window after KEXNW iterations. ==== + INTEGER KEXNW + PARAMETER ( KEXNW = 5 ) * * ==== Exceptional shifts: try to cure rare slow convergence * . with ad-hoc exceptional shifts every KEXSH iterations. -* . The constants WILK1 and WILK2 are used to form the -* . exceptional shifts. ==== +* . ==== + INTEGER KEXSH + PARAMETER ( KEXSH = 6 ) * - INTEGER NTINY - PARAMETER ( NTINY = 11 ) - INTEGER KEXNW, KEXSH - PARAMETER ( KEXNW = 5, KEXSH = 6 ) +* ==== The constant WILK1 is used to form the exceptional +* . shifts. ==== DOUBLE PRECISION WILK1 PARAMETER ( WILK1 = 0.75d0 ) COMPLEX*16 ZERO, ONE @@ -190,9 +193,9 @@ DOUBLE PRECISION S INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS, $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS, - $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX, - $ NSR, NVE, NW, NWMAX, NWR - LOGICAL NWINC, SORTED + $ LWKOPT, NDEC, NDFL, NH, NHO, NIBBLE, NMIN, NS, + $ NSMAX, NSR, NVE, NW, NWMAX, NWR, NWUPBD + LOGICAL SORTED CHARACTER JBCMPZ*2 * .. * .. External Functions .. @@ -225,24 +228,9 @@ RETURN END IF * -* ==== Set up job flags for ILAENV. ==== -* - IF( WANTT ) THEN - JBCMPZ( 1: 1 ) = 'S' - ELSE - JBCMPZ( 1: 1 ) = 'E' - END IF - IF( WANTZ ) THEN - JBCMPZ( 2: 2 ) = 'V' - ELSE - JBCMPZ( 2: 2 ) = 'N' - END IF -* -* ==== Tiny matrices must use ZLAHQR. ==== -* IF( N.LE.NTINY ) THEN * -* ==== Estimate optimal workspace. ==== +* ==== Tiny matrices must use ZLAHQR. ==== * LWKOPT = 1 IF( LWORK.NE.-1 ) @@ -257,6 +245,19 @@ * INFO = 0 * +* ==== Set up job flags for ILAENV. ==== +* + IF( WANTT ) THEN + JBCMPZ( 1: 1 ) = 'S' + ELSE + JBCMPZ( 1: 1 ) = 'E' + END IF + IF( WANTZ ) THEN + JBCMPZ( 2: 2 ) = 'V' + ELSE + JBCMPZ( 2: 2 ) = 'N' + END IF +* * ==== NWR = recommended deflation window size. At this * . point, N .GT. NTINY = 11, so there is enough * . subdiagonal workspace for NWR.GE.2 as required. @@ -266,7 +267,6 @@ NWR = ILAENV( 13, 'ZLAQR4', JBCMPZ, N, ILO, IHI, LWORK ) NWR = MAX( 2, NWR ) NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR ) - NW = NWR * * ==== NSR = recommended number of simultaneous shifts. * . At this point N .GT. NTINY = 11, so there is at @@ -317,6 +317,7 @@ * . which there is sufficient workspace. ==== * NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 ) + NW = NWMAX * * ==== NSMAX = the Largest number of simultaneous shifts * . for which there is sufficient workspace. ==== @@ -355,50 +356,46 @@ 20 CONTINUE KTOP = K * -* ==== Select deflation window size ==== +* ==== Select deflation window size: +* . Typical Case: +* . If possible and advisable, nibble the entire +* . active block. If not, use size MIN(NWR,NWMAX) +* . or MIN(NWR+1,NWMAX) depending upon which has +* . the smaller corresponding subdiagonal entry +* . (a heuristic). +* . +* . Exceptional Case: +* . If there have been no deflations in KEXNW or +* . more iterations, then vary the deflation window +* . size. At first, because, larger windows are, +* . in general, more powerful than smaller ones, +* . rapidly increase the window to the maximum possible. +* . Then, gradually reduce the window size. ==== * NH = KBOT - KTOP + 1 - IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN -* -* ==== Typical deflation window. If possible and -* . advisable, nibble the entire active block. -* . If not, use size NWR or NWR+1 depending upon -* . which has the smaller corresponding subdiagonal -* . entry (a heuristic). ==== -* - NWINC = .TRUE. - IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN - NW = NH - ELSE - NW = MIN( NWR, NH, NWMAX ) - IF( NW.LT.NWMAX ) THEN - IF( NW.GE.NH-1 ) THEN - NW = NH - ELSE - KWTOP = KBOT - NW + 1 - IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. - $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 - END IF - END IF - END IF + NWUPBD = MIN( NH, NWMAX ) + IF( NDFL.LT.KEXNW ) THEN + NW = MIN( NWUPBD, NWR ) ELSE -* -* ==== Exceptional deflation window. If there have -* . been no deflations in KEXNW or more iterations, -* . then vary the deflation window size. At first, -* . because, larger windows are, in general, more -* . powerful than smaller ones, rapidly increase the -* . window up to the maximum reasonable and possible. -* . Then maybe try a slightly smaller window. ==== -* - IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN - NW = MIN( NWMAX, NH, 2*NW ) + NW = MIN( NWUPBD, 2*NW ) + END IF + IF( NW.LT.NWMAX ) THEN + IF( NW.GE.NH-1 ) THEN + NW = NH ELSE - NWINC = .FALSE. - IF( NW.EQ.NH .AND. NH.GT.2 ) - $ NW = NH - 1 + KWTOP = KBOT - NW + 1 + IF( CABS1( H( KWTOP, KWTOP-1 ) ).GT. + $ CABS1( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1 END IF END IF + IF( NDFL.LT.KEXNW ) THEN + NDEC = -1 + ELSE IF( NDEC.GE.0 .OR. NW.GE.NWUPBD ) THEN + NDEC = NDEC + 1 + IF( NW-NDEC.LT.2 ) + $ NDEC = 0 + NW = NW - NDEC + END IF * * ==== Aggressive early deflation: * . split workspace under the subdiagonal into diff --git a/SRC/zlaqr5.f b/SRC/zlaqr5.f index fa8de7bb..d112531f 100644 --- a/SRC/zlaqr5.f +++ b/SRC/zlaqr5.f @@ -2,8 +2,8 @@ $ H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, $ WV, LDWV, NH, WH, LDWH ) * -* -- LAPACK auxiliary routine (version 3.1) -- -* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* -- LAPACK auxiliary routine (version 3.2) -- +* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. * November 2006 * * .. Scalar Arguments .. @@ -57,9 +57,9 @@ * NSHFTS gives the number of simultaneous shifts. NSHFTS * must be positive and even. * -* S (input) COMPLEX*16 array of size (NSHFTS) +* S (input/output) COMPLEX*16 array of size (NSHFTS) * S contains the shifts of origin that define the multi- -* shift QR sweep. +* shift QR sweep. On output S may be reordered. * * H (input/output) COMPLEX*16 array of size (LDH,N) * On input H contains a Hessenberg matrix. On output a @@ -125,15 +125,15 @@ * Karen Braman and Ralph Byers, Department of Mathematics, * University of Kansas, USA * -* ============================================================ -* Reference: +* ================================================================ +* Reference: * -* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR -* Algorithm Part I: Maintaining Well Focused Shifts, and -* Level 3 Performance, SIAM Journal of Matrix Analysis, -* volume 23, pages 929--947, 2002. +* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR +* Algorithm Part I: Maintaining Well Focused Shifts, and +* Level 3 Performance, SIAM Journal of Matrix Analysis, +* volume 23, pages 929--947, 2002. * -* ============================================================ +* ================================================================ * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), @@ -185,7 +185,7 @@ IF( KTOP.GE.KBOT ) $ RETURN * -* ==== NSHFTS is supposed to be even, but if is odd, +* ==== NSHFTS is supposed to be even, but if it is odd, * . then simply reduce it by one. ==== * NS = NSHFTS - MOD( NSHFTS, 2 ) @@ -271,19 +271,12 @@ CALL ZLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) ) * * ==== A Bulge may collapse because of vigilant -* . deflation or destructive underflow. (The -* . initial bulge is always collapsed.) Use -* . the two-small-subdiagonals trick to try -* . to get it started again. If V(2,M).NE.0 and -* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then -* . this bulge is collapsing into a zero -* . subdiagonal. It will be restarted next -* . trip through the loop.) -* - IF( V( 1, M ).NE.ZERO .AND. - $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3, - $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) ) - $ THEN +* . deflation or destructive underflow. In the +* . underflow case, try the two-small-subdiagonals +* . trick to try to reinflate the bulge. ==== +* + IF( H( K+3, K ).NE.ZERO .OR. H( K+3, K+1 ).NE. + $ ZERO .OR. H( K+3, K+2 ).EQ.ZERO ) THEN * * ==== Typical case: not collapsed (yet). ==== * @@ -293,46 +286,31 @@ ELSE * * ==== Atypical case: collapsed. Attempt to -* . reintroduce ignoring H(K+1,K). If the -* . fill resulting from the new reflector -* . is too large, then abandon it. +* . reintroduce ignoring H(K+1,K) and H(K+2,K). +* . If the fill resulting from the new +* . reflector is too large, then abandon it. * . Otherwise, use the new one. ==== * CALL ZLAQR1( 3, H( K+1, K+1 ), LDH, S( 2*M-1 ), $ S( 2*M ), VT ) - SCL = CABS1( VT( 1 ) ) + CABS1( VT( 2 ) ) + - $ CABS1( VT( 3 ) ) - IF( SCL.NE.RZERO ) THEN - VT( 1 ) = VT( 1 ) / SCL - VT( 2 ) = VT( 2 ) / SCL - VT( 3 ) = VT( 3 ) / SCL - END IF + ALPHA = VT( 1 ) + CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) + REFSUM = DCONJG( VT( 1 ) )* + $ ( H( K+1, K )+DCONJG( VT( 2 ) )* + $ H( K+2, K ) ) * -* ==== The following is the traditional and -* . conservative two-small-subdiagonals -* . test. ==== -* . - IF( CABS1( H( K+1, K ) )* - $ ( CABS1( VT( 2 ) )+CABS1( VT( 3 ) ) ).GT.ULP* - $ CABS1( VT( 1 ) )*( CABS1( H( K, - $ K ) )+CABS1( H( K+1, K+1 ) )+CABS1( H( K+2, - $ K+2 ) ) ) ) THEN + IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ + $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* + $ ( CABS1( H( K, K ) )+CABS1( H( K+1, + $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN * * ==== Starting a new bulge here would -* . create non-negligible fill. If -* . the old reflector is diagonal (only -* . possible with underflows), then -* . change it to I. Otherwise, use -* . it with trepidation. ==== -* - IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO ) - $ THEN - V( 1, M ) = ZERO - ELSE - H( K+1, K ) = BETA - H( K+2, K ) = ZERO - H( K+3, K ) = ZERO - END IF +* . create non-negligible fill. Use +* . the old one with trepidation. ==== +* + H( K+1, K ) = BETA + H( K+2, K ) = ZERO + H( K+3, K ) = ZERO ELSE * * ==== Stating a new bulge here would @@ -340,13 +318,7 @@ * . Replace the old reflector with * . the new one. ==== * - ALPHA = VT( 1 ) - CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = H( K+1, K ) + - $ H( K+2, K )*DCONJG( VT( 2 ) ) + - $ H( K+3, K )*DCONJG( VT( 3 ) ) - H( K+1, K ) = H( K+1, K ) - - $ DCONJG( VT( 1 ) )*REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) @@ -373,12 +345,6 @@ H( K+1, K ) = BETA H( K+2, K ) = ZERO END IF - ELSE -* -* ==== Initialize V(1,M22) here to avoid possible undefined -* . variable problems later. ==== -* - V( 1, M22 ) = ZERO END IF * * ==== Multiply H by reflections from the left ==== @@ -679,7 +645,7 @@ CALL ZGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU, $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH ) * -* ==== Copy top of H bottom of WH ==== +* ==== Copy top of H to bottom of WH ==== * CALL ZLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH, $ WH( I2+1, 1 ), LDWH ) diff --git a/SRC/zlaqsb.f b/SRC/zlaqsb.f index b4d0e114..a5456e1f 100644 --- a/SRC/zlaqsb.f +++ b/SRC/zlaqsb.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqsp.f b/SRC/zlaqsp.f index 24dc55aa..efef6f36 100644 --- a/SRC/zlaqsp.f +++ b/SRC/zlaqsp.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaqsy.f b/SRC/zlaqsy.f index 2a08bed3..08b94456 100644 --- a/SRC/zlaqsy.f +++ b/SRC/zlaqsy.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlar1v.f b/SRC/zlar1v.f index 52d71250..8a6ae3c5 100644 --- a/SRC/zlar1v.f +++ b/SRC/zlar1v.f @@ -2,7 +2,7 @@ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlar2v.f b/SRC/zlar2v.f index cb87cb89..cc8ce5d9 100644 --- a/SRC/zlar2v.f +++ b/SRC/zlar2v.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarcm.f b/SRC/zlarcm.f index 03f7be0c..f2ef6848 100644 --- a/SRC/zlarcm.f +++ b/SRC/zlarcm.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarf.f b/SRC/zlarf.f index a23f210d..98a46d61 100644 --- a/SRC/zlarf.f +++ b/SRC/zlarf.f @@ -1,7 +1,7 @@ SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarfb.f b/SRC/zlarfb.f index 112d592c..df2b7af4 100644 --- a/SRC/zlarfb.f +++ b/SRC/zlarfb.f @@ -2,7 +2,7 @@ $ T, LDT, C, LDC, WORK, LDWORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarfg.f b/SRC/zlarfg.f index f1e09dca..1df60caf 100644 --- a/SRC/zlarfg.f +++ b/SRC/zlarfg.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarfp.f b/SRC/zlarfp.f index 91190ba5..d983b3b9 100644 --- a/SRC/zlarfp.f +++ b/SRC/zlarfp.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARFP( N, ALPHA, X, INCX, TAU ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarft.f b/SRC/zlarft.f index 04006158..36275283 100644 --- a/SRC/zlarft.f +++ b/SRC/zlarft.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -240,13 +240,13 @@ * CALL ZTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + IF( I.GT.1 ) THEN + PREVLASTV = MIN( PREVLASTV, LASTV ) + ELSE + PREVLASTV = LASTV + END IF END IF T( I, I ) = TAU( I ) - IF( I.GT.1 ) THEN - PREVLASTV = MIN( PREVLASTV, LASTV ) - ELSE - PREVLASTV = LASTV - END IF END IF 40 CONTINUE END IF diff --git a/SRC/zlarfx.f b/SRC/zlarfx.f index 878e709b..e2ef43a0 100644 --- a/SRC/zlarfx.f +++ b/SRC/zlarfx.f @@ -1,7 +1,7 @@ SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) IMPLICIT NONE * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlargv.f b/SRC/zlargv.f index 4ef36fc3..1fde7fd8 100644 --- a/SRC/zlargv.f +++ b/SRC/zlargv.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarnv.f b/SRC/zlarnv.f index 78656a12..8cd09725 100644 --- a/SRC/zlarnv.f +++ b/SRC/zlarnv.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarrv.f b/SRC/zlarrv.f index 665d9382..2cde559c 100644 --- a/SRC/zlarrv.f +++ b/SRC/zlarrv.f @@ -4,7 +4,7 @@ $ IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, $ WORK, IWORK, INFO ) * -* -- LAPACK auxiliary routine (version 3.1.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarscl2.f b/SRC/zlarscl2.f new file mode 100644 index 00000000..c5af11a2 --- /dev/null +++ b/SRC/zlarscl2.f @@ -0,0 +1,54 @@ + SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + COMPLEX*16 X( LDX, * ) + DOUBLE PRECISION D( * ) +* .. +* +* Purpose +* ======= +* +* ZLARSCL2 performs a reciprocal diagonal scaling on an vector: +* x <-- inv(D) * x +* where the diagonal matrix D is stored as a vector. +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) DOUBLE PRECISION array, length N +* Diagonal matrix D, stored as a vector of length N. +* X (input/output) COMPLEX*16 array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) / D(I) + END DO + END DO +* + RETURN + END +* diff --git a/SRC/zlartg.f b/SRC/zlartg.f index 6d3a850e..fdae7fc5 100644 --- a/SRC/zlartg.f +++ b/SRC/zlartg.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARTG( F, G, CS, SN, R ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlartv.f b/SRC/zlartv.f index ae910b64..27a50e7e 100644 --- a/SRC/zlartv.f +++ b/SRC/zlartv.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarz.f b/SRC/zlarz.f index 18124672..190a6fa6 100644 --- a/SRC/zlarz.f +++ b/SRC/zlarz.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarzb.f b/SRC/zlarzb.f index 05d2a0e3..fd9a3ee2 100644 --- a/SRC/zlarzb.f +++ b/SRC/zlarzb.f @@ -1,7 +1,7 @@ SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ LDV, T, LDT, C, LDC, WORK, LDWORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlarzt.f b/SRC/zlarzt.f index 9242ed36..63a88e0c 100644 --- a/SRC/zlarzt.f +++ b/SRC/zlarzt.f @@ -1,6 +1,6 @@ SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlascl.f b/SRC/zlascl.f index cb296405..e116bba6 100644 --- a/SRC/zlascl.f +++ b/SRC/zlascl.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlascl2.f b/SRC/zlascl2.f new file mode 100644 index 00000000..ba0b29b9 --- /dev/null +++ b/SRC/zlascl2.f @@ -0,0 +1,54 @@ + SUBROUTINE ZLASCL2 ( M, N, D, X, LDX ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER M, N, LDX +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ) + COMPLEX*16 X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* ZLASCL2 performs a diagonal scaling on a vector: +* x <-- D * x +* where the diagonal matrix D is stored as a vector. +* Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS +* standard. +* +* Arguments +* ========= +* N (input) INTEGER +* The size of the vectors X and D. +* +* D (input) DOUBLE PRECISION array, length N +* Diagonal matrix D, stored as a vector of length N. +* X (input/output) COMPLEX*16 array, length N +* On entry, the vector X to be scaled by D. +* On exit, the scaled vector. +* .. +* .. Local Scalars .. + INTEGER I, J +* .. +* .. Executable Statements .. +* + DO J = 1, N + DO I = 1, M + X(I,J) = X(I,J) * D(I) + END DO + END DO +* + RETURN + END +* diff --git a/SRC/zlaset.f b/SRC/zlaset.f index 88fc21b2..79145b24 100644 --- a/SRC/zlaset.f +++ b/SRC/zlaset.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlasr.f b/SRC/zlasr.f index 507a20c4..989497da 100644 --- a/SRC/zlasr.f +++ b/SRC/zlasr.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlassq.f b/SRC/zlassq.f index a209984b..a55631ea 100644 --- a/SRC/zlassq.f +++ b/SRC/zlassq.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlaswp.f b/SRC/zlaswp.f index 8b07e48b..cc1b9ea2 100644 --- a/SRC/zlaswp.f +++ b/SRC/zlaswp.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlasyf.f b/SRC/zlasyf.f index 429131ff..b3eec57a 100644 --- a/SRC/zlasyf.f +++ b/SRC/zlasyf.f @@ -1,6 +1,6 @@ SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlat2c.f b/SRC/zlat2c.f new file mode 100644 index 00000000..a85dcde0 --- /dev/null +++ b/SRC/zlat2c.f @@ -0,0 +1,110 @@ + SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO ) +* +* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* May 2007 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LDSA, N +* .. +* .. Array Arguments .. + COMPLEX SA( LDSA, * ) + COMPLEX*16 A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX +* triangular matrix, A. +* +* RMAX is the overflow for the SINGLE PRECISION arithmetic +* ZLAT2C checks that all the entries of A are between -RMAX and +* RMAX. If not the convertion is aborted and a flag is raised. +* +* This is an auxiliary routine so there is no argument checking. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* On entry, the N-by-N triangular coefficient matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* SA (output) COMPLEX array, dimension (LDSA,N) +* Only the UPLO part of SA is referenced. On exit, if INFO=0, +* the N-by-N coefficient matrix SA; if INFO>0, the content of +* the UPLO part of SA is unspecified. +* +* LDSA (input) INTEGER +* The leading dimension of the array SA. LDSA >= max(1,M). +* +* INFO (output) INTEGER +* = 0: successful exit. +* = 1: an entry of the matrix A is greater than the SINGLE +* PRECISION overflow threshold, in this case, the content +* of the UPLO part of SA in exit is unspecified. +* +* ========= +* +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION RMAX + LOGICAL UPPER +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DIMAG +* .. +* .. External Functions .. + REAL SLAMCH + LOGICAL LSAME + EXTERNAL SLAMCH, LSAME +* .. +* .. Executable Statements .. +* + RMAX = SLAMCH( 'O' ) + UPPER = LSAME( UPLO, 'U' ) + IF( UPPER ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + IF( ( DBLE( A( I, J ) ).LT.-RMAX ) .OR. + + ( DBLE( A( I, J ) ).GT.RMAX ) .OR. + + ( DIMAG( A( I, J ) ).LT.-RMAX ) .OR. + + ( DIMAG( A( I, J ) ).GT.RMAX ) ) THEN + INFO = 1 + GO TO 50 + END IF + SA( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + IF( ( DBLE( A( I, J ) ).LT.-RMAX ) .OR. + + ( DBLE( A( I, J ) ).GT.RMAX ) .OR. + + ( DIMAG( A( I, J ) ).LT.-RMAX ) .OR. + + ( DIMAG( A( I, J ) ).GT.RMAX ) ) THEN + INFO = 1 + GO TO 50 + END IF + SA( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + 50 CONTINUE +* + RETURN +* +* End of ZLAT2C +* + END diff --git a/SRC/zlatbs.f b/SRC/zlatbs.f index 5dccd835..3a7d297b 100644 --- a/SRC/zlatbs.f +++ b/SRC/zlatbs.f @@ -1,7 +1,7 @@ SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, $ SCALE, CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlatdf.f b/SRC/zlatdf.f index d637b8f1..60b0c475 100644 --- a/SRC/zlatdf.f +++ b/SRC/zlatdf.f @@ -1,7 +1,7 @@ SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, $ JPIV ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlatps.f b/SRC/zlatps.f index 5092d603..bb471a9e 100644 --- a/SRC/zlatps.f +++ b/SRC/zlatps.f @@ -1,7 +1,7 @@ SUBROUTINE ZLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlatrd.f b/SRC/zlatrd.f index 5fef7b5c..74a75260 100644 --- a/SRC/zlatrd.f +++ b/SRC/zlatrd.f @@ -1,6 +1,6 @@ SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlatrs.f b/SRC/zlatrs.f index 7466096c..ed19e9fd 100644 --- a/SRC/zlatrs.f +++ b/SRC/zlatrs.f @@ -1,7 +1,7 @@ SUBROUTINE ZLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, $ CNORM, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlatrz.f b/SRC/zlatrz.f index 09af735a..8e3b6a61 100644 --- a/SRC/zlatrz.f +++ b/SRC/zlatrz.f @@ -1,6 +1,6 @@ SUBROUTINE ZLATRZ( M, N, L, A, LDA, TAU, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlatzm.f b/SRC/zlatzm.f index 1865f773..ebe0b0cf 100644 --- a/SRC/zlatzm.f +++ b/SRC/zlatzm.f @@ -1,6 +1,6 @@ SUBROUTINE ZLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlauu2.f b/SRC/zlauu2.f index 03e95ecc..6ed0ddac 100644 --- a/SRC/zlauu2.f +++ b/SRC/zlauu2.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAUU2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zlauum.f b/SRC/zlauum.f index d408bbcc..09d12745 100644 --- a/SRC/zlauum.f +++ b/SRC/zlauum.f @@ -1,6 +1,6 @@ SUBROUTINE ZLAUUM( UPLO, N, A, LDA, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbcon.f b/SRC/zpbcon.f index 004cffc6..fc5a40d4 100644 --- a/SRC/zpbcon.f +++ b/SRC/zpbcon.f @@ -1,7 +1,7 @@ SUBROUTINE ZPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbequ.f b/SRC/zpbequ.f index dd8bc9d3..082faf87 100644 --- a/SRC/zpbequ.f +++ b/SRC/zpbequ.f @@ -1,6 +1,6 @@ SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbrfs.f b/SRC/zpbrfs.f index 7120ae12..eeaf82f9 100644 --- a/SRC/zpbrfs.f +++ b/SRC/zpbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbstf.f b/SRC/zpbstf.f index 54f60507..70ff5671 100644 --- a/SRC/zpbstf.f +++ b/SRC/zpbstf.f @@ -1,6 +1,6 @@ SUBROUTINE ZPBSTF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbsv.f b/SRC/zpbsv.f index 83ca7094..971d93fc 100644 --- a/SRC/zpbsv.f +++ b/SRC/zpbsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbsvx.f b/SRC/zpbsvx.f index 6fb5d36b..7e847a80 100644 --- a/SRC/zpbsvx.f +++ b/SRC/zpbsvx.f @@ -2,7 +2,7 @@ $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, $ WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbtf2.f b/SRC/zpbtf2.f index 13b58a8c..d52dc731 100644 --- a/SRC/zpbtf2.f +++ b/SRC/zpbtf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZPBTF2( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbtrf.f b/SRC/zpbtrf.f index 18abd23b..15a7798c 100644 --- a/SRC/zpbtrf.f +++ b/SRC/zpbtrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZPBTRF( UPLO, N, KD, AB, LDAB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpbtrs.f b/SRC/zpbtrs.f index ccca34f0..5d49dc2c 100644 --- a/SRC/zpbtrs.f +++ b/SRC/zpbtrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpftrf.f b/SRC/zpftrf.f new file mode 100644 index 00000000..715b0b33 --- /dev/null +++ b/SRC/zpftrf.f @@ -0,0 +1,419 @@ + SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER N, INFO +* .. +* .. Array Arguments .. + COMPLEX*16 A( 0: * ) +* +* Purpose +* ======= +* +* ZPFTRF computes the Cholesky factorization of a complex Hermitian +* positive definite matrix A. +* +* The factorization has the form +* A = U**H * U, if UPLO = 'U', or +* A = L * L**H, if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular. +* +* This is the block version of the algorithm, calling Level 3 BLAS. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX array, dimension ( N*(N+1)/2 ); +* On entry, the Hermitian matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is +* the Conjugate-transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization RFP A = U**H*U or RFP A = L*L**H. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the leading minor of order i is not +* positive definite, and the factorization could not be +* completed. +* +* Further Notes on RFP Format: +* ============================ +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + COMPLEX*16 CONE + PARAMETER ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZHERK, ZPOTRF, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPFTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL ZPOTRF( 'L', N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE, A( 0 ), N, + + A( N1 ), N ) + CALL ZHERK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE, + + A( N ), N ) + CALL ZPOTRF( 'U', N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL ZPOTRF( 'L', N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'L', 'L', 'N', 'N', N1, N2, CONE, A( N2 ), N, + + A( 0 ), N ) + CALL ZHERK( 'U', 'C', N2, N1, -ONE, A( 0 ), N, ONE, + + A( N1 ), N ) + CALL ZPOTRF( 'U', N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + CALL ZPOTRF( 'U', N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE, A( 0 ), N1, + + A( N1*N1 ), N1 ) + CALL ZHERK( 'L', 'C', N2, N1, -ONE, A( N1*N1 ), N1, ONE, + + A( 1 ), N1 ) + CALL ZPOTRF( 'L', N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + CALL ZPOTRF( 'U', N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'R', 'U', 'N', 'N', N2, N1, CONE, A( N2*N2 ), + + N2, A( 0 ), N2 ) + CALL ZHERK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE, + + A( N1*N2 ), N2 ) + CALL ZPOTRF( 'L', N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL ZPOTRF( 'L', K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'R', 'L', 'C', 'N', K, K, CONE, A( 1 ), N+1, + + A( K+1 ), N+1 ) + CALL ZHERK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE, + + A( 0 ), N+1 ) + CALL ZPOTRF( 'U', K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL ZPOTRF( 'L', K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'L', 'L', 'N', 'N', K, K, CONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL ZHERK( 'U', 'C', K, K, -ONE, A( 0 ), N+1, ONE, + + A( K ), N+1 ) + CALL ZPOTRF( 'U', K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL ZPOTRF( 'U', K, A( 0+K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'L', 'U', 'C', 'N', K, K, CONE, A( K ), N1, + + A( K*( K+1 ) ), K ) + CALL ZHERK( 'L', 'C', K, K, -ONE, A( K*( K+1 ) ), K, ONE, + + A( 0 ), K ) + CALL ZPOTRF( 'L', K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL ZPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRSM( 'R', 'U', 'N', 'N', K, K, CONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL ZHERK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE, + + A( K*K ), K ) + CALL ZPOTRF( 'L', K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZPFTRF +* + END diff --git a/SRC/zpftri.f b/SRC/zpftri.f new file mode 100644 index 00000000..c986a43d --- /dev/null +++ b/SRC/zpftri.f @@ -0,0 +1,384 @@ + SUBROUTINE ZPFTRI( TRANSR, UPLO, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. Array Arguments .. + COMPLEX*16 A( 0: * ) +* .. +* +* Purpose +* ======= +* +* ZPFTRI computes the inverse of a complex Hermitian positive definite +* matrix A using the Cholesky factorization A = U**H*U or A = L*L**H +* computed by ZPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ); +* On entry, the Hermitian matrix A in RFP format. RFP format is +* described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' +* then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is +* the Conjugate-transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A. If UPLO = 'L' the RFP A contains the elements +* of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR = +* 'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N +* is odd. See the Note below for more details. +* +* On exit, the Hermitian inverse of the original matrix, in the +* same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the (i,i) element of the factor U or L is +* zero, and the inverse could not be computed. +* +* Note: +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + COMPLEX*16 CONE + PARAMETER ( ONE = 1.D0, CONE = ( 1.D0, 0.D0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTFTRI, ZLAUUM, ZTRMM, ZHERK +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* Invert the triangular Cholesky factor U or L. +* + CALL ZTFTRI( TRANSR, UPLO, 'N', N, A, INFO ) + IF( INFO.GT.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* Start execution of triangular matrix multiply: inv(U)*inv(U)^C or +* inv(L)^C*inv(L). There are eight cases. +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:N1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(N1,0) +* T1 -> a(0), T2 -> a(n), S -> a(N1) +* + CALL ZLAUUM( 'L', N1, A( 0 ), N, INFO ) + CALL ZHERK( 'L', 'C', N1, N2, ONE, A( N1 ), N, ONE, + + A( 0 ), N ) + CALL ZTRMM( 'L', 'U', 'N', 'N', N2, N1, CONE, A( N ), N, + + A( N1 ), N ) + CALL ZLAUUM( 'U', N2, A( N ), N, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:N2-1) +* T1 -> a(N1+1,0), T2 -> a(N1,0), S -> a(0,0) +* T1 -> a(N2), T2 -> a(N1), S -> a(0) +* + CALL ZLAUUM( 'L', N1, A( N2 ), N, INFO ) + CALL ZHERK( 'L', 'N', N1, N2, ONE, A( 0 ), N, ONE, + + A( N2 ), N ) + CALL ZTRMM( 'R', 'U', 'C', 'N', N1, N2, CONE, A( N1 ), N, + + A( 0 ), N ) + CALL ZLAUUM( 'U', N2, A( N1 ), N, INFO ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+N1*N1) +* + CALL ZLAUUM( 'U', N1, A( 0 ), N1, INFO ) + CALL ZHERK( 'U', 'N', N1, N2, ONE, A( N1*N1 ), N1, ONE, + + A( 0 ), N1 ) + CALL ZTRMM( 'R', 'L', 'N', 'N', N1, N2, CONE, A( 1 ), N1, + + A( N1*N1 ), N1 ) + CALL ZLAUUM( 'L', N2, A( 1 ), N1, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is odd +* T1 -> a(0+N2*N2), T2 -> a(0+N1*N2), S -> a(0) +* + CALL ZLAUUM( 'U', N1, A( N2*N2 ), N2, INFO ) + CALL ZHERK( 'U', 'C', N1, N2, ONE, A( 0 ), N2, ONE, + + A( N2*N2 ), N2 ) + CALL ZTRMM( 'L', 'L', 'C', 'N', N2, N1, CONE, A( N1*N2 ), + + N2, A( 0 ), N2 ) + CALL ZLAUUM( 'L', N2, A( N1*N2 ), N2, INFO ) +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL ZLAUUM( 'L', K, A( 1 ), N+1, INFO ) + CALL ZHERK( 'L', 'C', K, K, ONE, A( K+1 ), N+1, ONE, + + A( 1 ), N+1 ) + CALL ZTRMM( 'L', 'U', 'N', 'N', K, K, CONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) + CALL ZLAUUM( 'U', K, A( 0 ), N+1, INFO ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL ZLAUUM( 'L', K, A( K+1 ), N+1, INFO ) + CALL ZHERK( 'L', 'N', K, K, ONE, A( 0 ), N+1, ONE, + + A( K+1 ), N+1 ) + CALL ZTRMM( 'R', 'U', 'C', 'N', K, K, CONE, A( K ), N+1, + + A( 0 ), N+1 ) + CALL ZLAUUM( 'U', K, A( K ), N+1, INFO ) +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1), +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL ZLAUUM( 'U', K, A( K ), K, INFO ) + CALL ZHERK( 'U', 'N', K, K, ONE, A( K*( K+1 ) ), K, ONE, + + A( K ), K ) + CALL ZTRMM( 'R', 'L', 'N', 'N', K, K, CONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + CALL ZLAUUM( 'L', K, A( 0 ), K, INFO ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE, and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0), +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL ZLAUUM( 'U', K, A( K*( K+1 ) ), K, INFO ) + CALL ZHERK( 'U', 'C', K, K, ONE, A( 0 ), K, ONE, + + A( K*( K+1 ) ), K ) + CALL ZTRMM( 'L', 'L', 'C', 'N', K, K, CONE, A( K*K ), K, + + A( 0 ), K ) + CALL ZLAUUM( 'L', K, A( K*K ), K, INFO ) +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZPFTRI +* + END diff --git a/SRC/zpftrs.f b/SRC/zpftrs.f new file mode 100644 index 00000000..3fea6b1e --- /dev/null +++ b/SRC/zpftrs.f @@ -0,0 +1,230 @@ + SUBROUTINE ZPFTRS( TRANSR, UPLO, N, NRHS, A, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, LDB, N, NRHS +* .. +* .. Array Arguments .. + COMPLEX*16 A( 0: * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* ZPFTRS solves a system of linear equations A*X = B with a Hermitian +* positive definite matrix A using the Cholesky factorization +* A = U**H*U or A = L*L**H computed by ZPFTRF. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': Upper triangle of RFP A is stored; +* = 'L': Lower triangle of RFP A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); +* The triangular factor U or L from the Cholesky factorization +* of RFP A = U**H*U or RFP A = L*L**H, as computed by ZPFTRF. +* See note below for more details about RFP A. +* +* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Note: +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NORMALTRANSR +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTFSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPFTRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + + RETURN +* +* start execution: there are two triangular solves +* + IF( LOWER ) THEN + CALL ZTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, CONE, A, B, + + LDB ) + CALL ZTFSM( TRANSR, 'L', UPLO, 'C', 'N', N, NRHS, CONE, A, B, + + LDB ) + ELSE + CALL ZTFSM( TRANSR, 'L', UPLO, 'C', 'N', N, NRHS, CONE, A, B, + + LDB ) + CALL ZTFSM( TRANSR, 'L', UPLO, 'N', 'N', N, NRHS, CONE, A, B, + + LDB ) + END IF +* + RETURN +* +* End of ZPFTRS +* + END diff --git a/SRC/zpocon.f b/SRC/zpocon.f index af24264e..8002fff6 100644 --- a/SRC/zpocon.f +++ b/SRC/zpocon.f @@ -1,7 +1,7 @@ SUBROUTINE ZPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpoequ.f b/SRC/zpoequ.f index b9594438..36a81a2e 100644 --- a/SRC/zpoequ.f +++ b/SRC/zpoequ.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOEQU( N, A, LDA, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpoequb.f b/SRC/zpoequb.f new file mode 100644 index 00000000..f0330f93 --- /dev/null +++ b/SRC/zpoequb.f @@ -0,0 +1,160 @@ + SUBROUTINE ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + DOUBLE PRECISION S( * ) +* .. +* +* Purpose +* ======= +* +* ZPOEQUB computes row and column scalings intended to equilibrate a +* symmetric positive definite matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The N-by-N symmetric positive definite matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) DOUBLE PRECISION +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION SMIN, BASE, TMP + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT, LOG, INT, REAL, DIMAG +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* +* Positive definite only performs 1 pass of equilibration. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPOEQUB', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) THEN + SCOND = ONE + AMAX = ZERO + RETURN + END IF + + BASE = DLAMCH( 'B' ) + TMP = -0.5D+0 / LOG ( BASE ) +* +* Find the minimum and maximum diagonal elements. +* + S( 1 ) = A( 1, 1 ) + SMIN = S( 1 ) + AMAX = S( 1 ) + DO 10 I = 2, N + S( I ) = A( I, I ) + SMIN = MIN( SMIN, S( I ) ) + AMAX = MAX( AMAX, S( I ) ) + 10 CONTINUE +* + IF( SMIN.LE.ZERO ) THEN +* +* Find the first non-positive diagonal element and return. +* + DO 20 I = 1, N + IF( S( I ).LE.ZERO ) THEN + INFO = I + RETURN + END IF + 20 CONTINUE + ELSE +* +* Set the scale factors to the reciprocals +* of the diagonal elements. +* + DO 30 I = 1, N + S( I ) = BASE ** INT( TMP * LOG( S( I ) ) ) + 30 CONTINUE +* +* Compute SCOND = min(S(I)) / max(S(I)). +* + SCOND = SQRT( SMIN ) / SQRT( AMAX ) + END IF +* + RETURN +* +* End of ZPOEQUB +* + END diff --git a/SRC/zporfs.f b/SRC/zporfs.f index 22a52ea4..d7d11ca2 100644 --- a/SRC/zporfs.f +++ b/SRC/zporfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zporfsx.f b/SRC/zporfsx.f new file mode 100644 index 00000000..c5463ee5 --- /dev/null +++ b/SRC/zporfsx.f @@ -0,0 +1,568 @@ + Subroutine ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, + $ LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION RWORK( * ), S( * ), PARAMS(*), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* ZPORFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric positive +* definite, and provides error bounds and backward error estimates +* for the solution. In addition to normwise error bound, the code +* provides maximum componentwise error bound if possible. See +* comments for ERR_BNDS for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular part +* of the matrix A, and the strictly lower triangular part of A +* is not referenced. If UPLO = 'L', the leading N-by-N lower +* triangular part of A contains the lower triangular part of +* the matrix A, and the strictly upper triangular part of A is +* not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX*16 array, dimension (LDAF,N) +* The triangular factor U or L from the Cholesky factorization +* A = U**T*U or A = L*L**T, as computed by DPOTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) COMPLEX*16 array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 100.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZPOCON, ZLA_PORFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, ZLANHE, ZLA_PORCOND_X, ZLA_PORCOND_C + DOUBLE PRECISION DLAMCH, ZLANHE, ZLA_PORCOND_X, ZLA_PORCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS(LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS(LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF (.NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPORFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = ZLANHE( NORM, UPLO, N, A, LDA, WORK ) + CALL ZPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, RWORK, + $ INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK(N+1), WORK(1), WORK(2*N+1), WORK(1), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1 ) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = ZLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, + $ S, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = ZLA_PORCOND_C( UPLO, N, A, LDA, AF, LDAF, + $ S, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF + + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF (ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = ZLA_PORCOND_X( UPLO, N, A, LDA, AF, LDAF, + $ X(1,J), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF (RCOND_TMP .LT. ILLRCOND_THRESH) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of ZPORFSX +* + END diff --git a/SRC/zposv.f b/SRC/zposv.f index 6bcaf60a..1641b3a6 100644 --- a/SRC/zposv.f +++ b/SRC/zposv.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zposvx.f b/SRC/zposvx.f index ddf0524c..c63b9766 100644 --- a/SRC/zposvx.f +++ b/SRC/zposvx.f @@ -2,7 +2,7 @@ $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zposvxx.f b/SRC/zposvxx.f new file mode 100644 index 00000000..e83474c8 --- /dev/null +++ b/SRC/zposvxx.f @@ -0,0 +1,549 @@ + SUBROUTINE ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED, + $ S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ WORK( * ), X( LDX, * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* ZPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T +* to compute the solution to a complex*16 system of linear equations +* A * X = B, where A is an N-by-N symmetric positive definite matrix +* and X and B are N-by-NRHS matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. ZPOSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* ZPOSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* ZPOSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what ZPOSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to +* factor the matrix A (after equilibration if FACT = 'E') as +* A = U**T* U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is a lower triangular +* matrix. +* +* 3. If the leading i-by-i principal minor is not positive definite, +* then the routine returns with INFO = i. Otherwise, the factored +* form of A is used to estimate the condition number of the matrix +* A (see argument RCOND). If the reciprocal of the condition number +* is less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(S) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF contains the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A and AF are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = +* 'Y', then A must contain the equilibrated matrix +* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper +* triangular part of A contains the upper triangular part of the +* matrix A, and the strictly lower triangular part of A is not +* referenced. If UPLO = 'L', the leading N-by-N lower triangular +* part of A contains the lower triangular part of the matrix A, and +* the strictly upper triangular part of A is not referenced. A is +* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = +* 'N' on exit. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T, in the same storage +* format as A. If EQUED .ne. 'N', then AF is the factored +* form of the equilibrated matrix diag(S)*A*diag(S). +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the original +* matrix A. +* +* If FACT = 'E', then AF is an output argument and on exit +* returns the triangular factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T of the equilibrated +* matrix A (see the description of A for the form of the +* equilibrated matrix). +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The row scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX*16 array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, ZLA_PORPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLA_PORPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ZPOCON, ZPOEQUB, ZPOTRF, ZPOTRS, ZLACPY, + $ ZLAQHE, XERBLA, ZLASCL2, ZPORFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in ZPORFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until ZPORFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. + $ .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZPOSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL ZPOEQUB( N, A, LDA, S, SCOND, AMAX, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + END IF +* +* Scale the right-hand side. +* + IF( RCEQU ) CALL ZLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL ZPOTRF( UPLO, N, AF, LDAF, INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + RPVGRW = ZLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + RPVGRW = ZLA_PORPVGRW( UPLO, N, A, LDA, AF, LDAF, WORK ) +* +* Compute the solution matrix X. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL ZPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL ZPORFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO ) + +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL ZLASCL2( N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of ZPOSVXX +* + END diff --git a/SRC/zpotf2.f b/SRC/zpotf2.f index ca9df447..ef97106a 100644 --- a/SRC/zpotf2.f +++ b/SRC/zpotf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOTF2( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -73,9 +73,9 @@ DOUBLE PRECISION AJJ * .. * .. External Functions .. - LOGICAL LSAME + LOGICAL LSAME, DISNAN COMPLEX*16 ZDOTC - EXTERNAL LSAME, ZDOTC + EXTERNAL LSAME, ZDOTC, DISNAN * .. * .. External Subroutines .. EXTERNAL XERBLA, ZDSCAL, ZGEMV, ZLACGV @@ -116,7 +116,7 @@ * AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( 1, J ), 1, $ A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF @@ -143,7 +143,7 @@ * AJJ = DBLE( A( J, J ) ) - ZDOTC( J-1, A( J, 1 ), LDA, $ A( J, 1 ), LDA ) - IF( AJJ.LE.ZERO ) THEN + IF( AJJ.LE.ZERO.OR.DISNAN( AJJ ) ) THEN A( J, J ) = AJJ GO TO 30 END IF diff --git a/SRC/zpotrf.f b/SRC/zpotrf.f index 86772608..d333f1fb 100644 --- a/SRC/zpotrf.f +++ b/SRC/zpotrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOTRF( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpotri.f b/SRC/zpotri.f index ab3094a6..b4c8a98a 100644 --- a/SRC/zpotri.f +++ b/SRC/zpotri.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOTRI( UPLO, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpotrs.f b/SRC/zpotrs.f index d2136cca..09cb6044 100644 --- a/SRC/zpotrs.f +++ b/SRC/zpotrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zppcon.f b/SRC/zppcon.f index 100cac58..43369c77 100644 --- a/SRC/zppcon.f +++ b/SRC/zppcon.f @@ -1,6 +1,6 @@ SUBROUTINE ZPPCON( UPLO, N, AP, ANORM, RCOND, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zppequ.f b/SRC/zppequ.f index 990a5bd7..ca82c9d3 100644 --- a/SRC/zppequ.f +++ b/SRC/zppequ.f @@ -1,6 +1,6 @@ SUBROUTINE ZPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpprfs.f b/SRC/zpprfs.f index 365936c3..cfe6c6ea 100644 --- a/SRC/zpprfs.f +++ b/SRC/zpprfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, $ BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zppsv.f b/SRC/zppsv.f index 6c2809d0..1673d6c9 100644 --- a/SRC/zppsv.f +++ b/SRC/zppsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZPPSV( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zppsvx.f b/SRC/zppsvx.f index c3167479..b7c6c455 100644 --- a/SRC/zppsvx.f +++ b/SRC/zppsvx.f @@ -1,7 +1,7 @@ SUBROUTINE ZPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB, $ X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpptrf.f b/SRC/zpptrf.f index 738eec49..a28a969d 100644 --- a/SRC/zpptrf.f +++ b/SRC/zpptrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZPPTRF( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpptri.f b/SRC/zpptri.f index 98589bea..17c4e56a 100644 --- a/SRC/zpptri.f +++ b/SRC/zpptri.f @@ -1,6 +1,6 @@ SUBROUTINE ZPPTRI( UPLO, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpptrs.f b/SRC/zpptrs.f index 0a9b9266..5a582384 100644 --- a/SRC/zpptrs.f +++ b/SRC/zpptrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpstf2.f b/SRC/zpstf2.f new file mode 100644 index 00000000..3db059b1 --- /dev/null +++ b/SRC/zpstf2.f @@ -0,0 +1,327 @@ + SUBROUTINE ZPSTF2( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK PROTOTYPE routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + DOUBLE PRECISION WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* ZPSTF2 computes the Cholesky factorization with complete +* pivoting of a complex Hermitian positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 2 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) DOUBLE PRECISION +* User defined tolerance. If TOL < 0, then N*U*MAX( A( K,K ) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK DOUBLE PRECISION array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX*16 ZTEMP + DOUBLE PRECISION AJJ, DSTOP, DTEMP + INTEGER I, ITEMP, J, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME, DISNAN + EXTERNAL DLAMCH, LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL ZDSCAL, ZGEMV, ZLACGV, ZSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX, SQRT +* .. +* .. 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( 'ZPSTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + DO 110 I = 1, N + WORK( I ) = DBLE( A( I, I ) ) + 110 CONTINUE + PVT = MAXLOC( WORK( 1:N ), 1 ) + AJJ = DBLE( A( PVT, PVT ) ) + IF( AJJ.EQ.ZERO.OR.DISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 200 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ + ELSE + DSTOP = TOL + END IF +* +* Set first half of WORK to zero, holds dot products +* + DO 120 I = 1, N + WORK( I ) = 0 + 120 CONTINUE +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 150 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 130 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + + $ DBLE( DCONJG( A( J-1, I ) )* + $ A( J-1, I ) ) + END IF + WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I ) +* + 130 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL ZSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL ZSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + DO 140 I = J + 1, PVT - 1 + ZTEMP = DCONJG( A( J, I ) ) + A( J, I ) = DCONJG( A( I, PVT ) ) + A( I, PVT ) = ZTEMP + 140 CONTINUE + A( J, PVT ) = DCONJG( A( J, PVT ) ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J +* + IF( J.LT.N ) THEN + CALL ZLACGV( J-1, A( 1, J ), 1 ) + CALL ZGEMV( 'Trans', J-1, N-J, -CONE, A( 1, J+1 ), LDA, + $ A( 1, J ), 1, CONE, A( J, J+1 ), LDA ) + CALL ZLACGV( J-1, A( 1, J ), 1 ) + CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 150 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 180 J = 1, N +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 160 I = J, N +* + IF( J.GT.1 ) THEN + WORK( I ) = WORK( I ) + + $ DBLE( DCONJG( A( I, J-1 ) )* + $ A( I, J-1 ) ) + END IF + WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I ) +* + 160 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 190 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL ZSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL ZSWAP( N-PVT, A( PVT+1, J ), 1, A( PVT+1, PVT ), + $ 1 ) + DO 170 I = J + 1, PVT - 1 + ZTEMP = DCONJG( A( I, J ) ) + A( I, J ) = DCONJG( A( PVT, I ) ) + A( PVT, I ) = ZTEMP + 170 CONTINUE + A( PVT, J ) = DCONJG( A( PVT, J ) ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J +* + IF( J.LT.N ) THEN + CALL ZLACGV( J-1, A( J, 1 ), LDA ) + CALL ZGEMV( 'No Trans', N-J, J-1, -CONE, A( J+1, 1 ), + $ LDA, A( J, 1 ), LDA, CONE, A( J+1, J ), 1 ) + CALL ZLACGV( J-1, A( J, 1 ), LDA ) + CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 180 CONTINUE +* + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 200 + 190 CONTINUE +* +* Rank is number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 200 CONTINUE + RETURN +* +* End of ZPSTF2 +* + END diff --git a/SRC/zpstrf.f b/SRC/zpstrf.f new file mode 100644 index 00000000..827f55da --- /dev/null +++ b/SRC/zpstrf.f @@ -0,0 +1,385 @@ + SUBROUTINE ZPSTRF( UPLO, N, A, LDA, PIV, RANK, TOL, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION TOL + INTEGER INFO, LDA, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ) + DOUBLE PRECISION WORK( 2*N ) + INTEGER PIV( N ) +* .. +* +* Purpose +* ======= +* +* ZPSTRF computes the Cholesky factorization with complete +* pivoting of a complex Hermitian positive semidefinite matrix A. +* +* The factorization has the form +* P' * A * P = U' * U , if UPLO = 'U', +* P' * A * P = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular, and +* P is stored as vector PIV. +* +* This algorithm does not attempt to check that A is positive +* semidefinite. This version of the algorithm calls level 3 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization as above. +* +* PIV (output) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are P( PIV(K), K ) = 1. +* +* RANK (output) INTEGER +* The rank of A given by the number of steps the algorithm +* completed. +* +* TOL (input) DOUBLE PRECISION +* User defined tolerance. If TOL < 0, then N*U*MAX( A(K,K) ) +* will be used. The algorithm terminates at the (K-1)st step +* if the pivot <= TOL. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* WORK DOUBLE PRECISION array, dimension (2*N) +* Work space. +* +* INFO (output) INTEGER +* < 0: If INFO = -K, the K-th argument had an illegal value, +* = 0: algorithm completed successfully, and +* > 0: the matrix A is either rank deficient with computed rank +* as returned in RANK, or is indefinite. See Section 7 of +* LAPACK Working Note #161 for further information. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX*16 ZTEMP + DOUBLE PRECISION AJJ, DSTOP, DTEMP + INTEGER I, ITEMP, J, JB, K, NB, PVT + LOGICAL UPPER +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + LOGICAL LSAME, DISNAN + EXTERNAL DLAMCH, ILAENV, LSAME, DISNAN +* .. +* .. External Subroutines .. + EXTERNAL ZDSCAL, ZGEMV, ZHERK, ZLACGV, ZPSTF2, ZSWAP, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, MAX, MIN, SQRT, MAXLOC +* .. +* .. 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( 'ZPSTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Get block size +* + NB = ILAENV( 1, 'ZPOTRF', UPLO, N, -1, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code +* + CALL ZPSTF2( UPLO, N, A( 1, 1 ), LDA, PIV, RANK, TOL, WORK, + $ INFO ) + GO TO 230 +* + ELSE +* +* Initialize PIV +* + DO 100 I = 1, N + PIV( I ) = I + 100 CONTINUE +* +* Compute stopping value +* + DO 110 I = 1, N + WORK( I ) = DBLE( A( I, I ) ) + 110 CONTINUE + PVT = MAXLOC( WORK( 1:N ), 1 ) + AJJ = DBLE( A( PVT, PVT ) ) + IF( AJJ.EQ.ZERO.OR.DISNAN( AJJ ) ) THEN + RANK = 0 + INFO = 1 + GO TO 230 + END IF +* +* Compute stopping value if not supplied +* + IF( TOL.LT.ZERO ) THEN + DSTOP = N * DLAMCH( 'Epsilon' ) * AJJ + ELSE + DSTOP = TOL + END IF +* +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization P' * A * P = U' * U +* + DO 160 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 120 I = K, N + WORK( I ) = 0 + 120 CONTINUE +* + DO 150 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 130 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + + $ DBLE( DCONJG( A( J-1, I ) )* + $ A( J-1, I ) ) + END IF + WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I ) +* + 130 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 220 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL ZSWAP( J-1, A( 1, J ), 1, A( 1, PVT ), 1 ) + IF( PVT.LT.N ) + $ CALL ZSWAP( N-PVT, A( J, PVT+1 ), LDA, + $ A( PVT, PVT+1 ), LDA ) + DO 140 I = J + 1, PVT - 1 + ZTEMP = DCONJG( A( J, I ) ) + A( J, I ) = DCONJG( A( I, PVT ) ) + A( I, PVT ) = ZTEMP + 140 CONTINUE + A( J, PVT ) = DCONJG( A( J, PVT ) ) +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL ZLACGV( J-1, A( 1, J ), 1 ) + CALL ZGEMV( 'Trans', J-K, N-J, -CONE, A( K, J+1 ), + $ LDA, A( K, J ), 1, CONE, A( J, J+1 ), + $ LDA ) + CALL ZLACGV( J-1, A( 1, J ), 1 ) + CALL ZDSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF +* + 150 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL ZHERK( 'Upper', 'Conj Trans', N-J+1, JB, -ONE, + $ A( K, J ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 160 CONTINUE +* + ELSE +* +* Compute the Cholesky factorization P' * A * P = L * L' +* + DO 210 K = 1, N, NB +* +* Account for last block not being NB wide +* + JB = MIN( NB, N-K+1 ) +* +* Set relevant part of first half of WORK to zero, +* holds dot products +* + DO 170 I = K, N + WORK( I ) = 0 + 170 CONTINUE +* + DO 200 J = K, K + JB - 1 +* +* Find pivot, test for exit, else swap rows and columns +* Update dot products, compute possible pivots which are +* stored in the second half of WORK +* + DO 180 I = J, N +* + IF( J.GT.K ) THEN + WORK( I ) = WORK( I ) + + $ DBLE( DCONJG( A( I, J-1 ) )* + $ A( I, J-1 ) ) + END IF + WORK( N+I ) = DBLE( A( I, I ) ) - WORK( I ) +* + 180 CONTINUE +* + IF( J.GT.1 ) THEN + ITEMP = MAXLOC( WORK( (N+J):(2*N) ), 1 ) + PVT = ITEMP + J - 1 + AJJ = WORK( N+PVT ) + IF( AJJ.LE.DSTOP.OR.DISNAN( AJJ ) ) THEN + A( J, J ) = AJJ + GO TO 220 + END IF + END IF +* + IF( J.NE.PVT ) THEN +* +* Pivot OK, so can now swap pivot rows and columns +* + A( PVT, PVT ) = A( J, J ) + CALL ZSWAP( J-1, A( J, 1 ), LDA, A( PVT, 1 ), LDA ) + IF( PVT.LT.N ) + $ CALL ZSWAP( N-PVT, A( PVT+1, J ), 1, + $ A( PVT+1, PVT ), 1 ) + DO 190 I = J + 1, PVT - 1 + ZTEMP = DCONJG( A( I, J ) ) + A( I, J ) = DCONJG( A( PVT, I ) ) + A( PVT, I ) = ZTEMP + 190 CONTINUE + A( PVT, J ) = DCONJG( A( PVT, J ) ) +* +* +* Swap dot products and PIV +* + DTEMP = WORK( J ) + WORK( J ) = WORK( PVT ) + WORK( PVT ) = DTEMP + ITEMP = PIV( PVT ) + PIV( PVT ) = PIV( J ) + PIV( J ) = ITEMP + END IF +* + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL ZLACGV( J-1, A( J, 1 ), LDA ) + CALL ZGEMV( 'No Trans', N-J, J-K, -CONE, + $ A( J+1, K ), LDA, A( J, K ), LDA, CONE, + $ A( J+1, J ), 1 ) + CALL ZLACGV( J-1, A( J, 1 ), LDA ) + CALL ZDSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF +* + 200 CONTINUE +* +* Update trailing matrix, J already incremented +* + IF( K+JB.LE.N ) THEN + CALL ZHERK( 'Lower', 'No Trans', N-J+1, JB, -ONE, + $ A( J, K ), LDA, ONE, A( J, J ), LDA ) + END IF +* + 210 CONTINUE +* + END IF + END IF +* +* Ran to completion, A has full rank +* + RANK = N +* + GO TO 230 + 220 CONTINUE +* +* Rank is the number of steps completed. Set INFO = 1 to signal +* that the factorization cannot be used to solve a system. +* + RANK = J - 1 + INFO = 1 +* + 230 CONTINUE + RETURN +* +* End of ZPSTRF +* + END diff --git a/SRC/zptcon.f b/SRC/zptcon.f index 708fb378..df425ce0 100644 --- a/SRC/zptcon.f +++ b/SRC/zptcon.f @@ -1,6 +1,6 @@ SUBROUTINE ZPTCON( N, D, E, ANORM, RCOND, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpteqr.f b/SRC/zpteqr.f index eea96599..c80b3dc6 100644 --- a/SRC/zpteqr.f +++ b/SRC/zpteqr.f @@ -1,6 +1,6 @@ SUBROUTINE ZPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zptrfs.f b/SRC/zptrfs.f index 26398365..d08bf4f0 100644 --- a/SRC/zptrfs.f +++ b/SRC/zptrfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZPTRFS( UPLO, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zptsv.f b/SRC/zptsv.f index da0f7776..666d95f0 100644 --- a/SRC/zptsv.f +++ b/SRC/zptsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZPTSV( N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zptsvx.f b/SRC/zptsvx.f index 52b95f69..2c81fad9 100644 --- a/SRC/zptsvx.f +++ b/SRC/zptsvx.f @@ -1,7 +1,7 @@ SUBROUTINE ZPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX, $ RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpttrf.f b/SRC/zpttrf.f index 6deda45f..49ed6db7 100644 --- a/SRC/zpttrf.f +++ b/SRC/zpttrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZPTTRF( N, D, E, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zpttrs.f b/SRC/zpttrs.f index e372d00b..9afe775f 100644 --- a/SRC/zpttrs.f +++ b/SRC/zpttrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZPTTRS( UPLO, N, NRHS, D, E, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zptts2.f b/SRC/zptts2.f index e2a90fc3..356c5cc0 100644 --- a/SRC/zptts2.f +++ b/SRC/zptts2.f @@ -1,6 +1,6 @@ SUBROUTINE ZPTTS2( IUPLO, N, NRHS, D, E, B, LDB ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -1,6 +1,6 @@ SUBROUTINE ZROT( N, CX, INCX, CY, INCY, C, S ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zspcon.f b/SRC/zspcon.f index edd2ab43..be6927b5 100644 --- a/SRC/zspcon.f +++ b/SRC/zspcon.f @@ -1,6 +1,6 @@ SUBROUTINE ZSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zspmv.f b/SRC/zspmv.f index c8b9fba6..ec54418e 100644 --- a/SRC/zspmv.f +++ b/SRC/zspmv.f @@ -1,6 +1,6 @@ SUBROUTINE ZSPMV( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -1,6 +1,6 @@ SUBROUTINE ZSPR( UPLO, N, ALPHA, X, INCX, AP ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsprfs.f b/SRC/zsprfs.f index 93661a04..58a6a20f 100644 --- a/SRC/zsprfs.f +++ b/SRC/zsprfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zspsv.f b/SRC/zspsv.f index 46f73786..e7dc28a9 100644 --- a/SRC/zspsv.f +++ b/SRC/zspsv.f @@ -1,6 +1,6 @@ SUBROUTINE ZSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zspsvx.f b/SRC/zspsvx.f index 70704e06..62a7f6e7 100644 --- a/SRC/zspsvx.f +++ b/SRC/zspsvx.f @@ -1,7 +1,7 @@ SUBROUTINE ZSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, $ LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsptrf.f b/SRC/zsptrf.f index 30f9295c..0e59f446 100644 --- a/SRC/zsptrf.f +++ b/SRC/zsptrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZSPTRF( UPLO, N, AP, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsptri.f b/SRC/zsptri.f index fe0cc2a7..2263e686 100644 --- a/SRC/zsptri.f +++ b/SRC/zsptri.f @@ -1,6 +1,6 @@ SUBROUTINE ZSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsptrs.f b/SRC/zsptrs.f index a76a456c..7f342125 100644 --- a/SRC/zsptrs.f +++ b/SRC/zsptrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zstedc.f b/SRC/zstedc.f index 88be1d31..716cbed5 100644 --- a/SRC/zstedc.f +++ b/SRC/zstedc.f @@ -1,7 +1,7 @@ SUBROUTINE ZSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, RWORK, $ LRWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zstegr.f b/SRC/zstegr.f index 597c8ff5..ca0ee5d8 100644 --- a/SRC/zstegr.f +++ b/SRC/zstegr.f @@ -5,7 +5,7 @@ IMPLICIT NONE * * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zstein.f b/SRC/zstein.f index 615066af..718b0419 100644 --- a/SRC/zstein.f +++ b/SRC/zstein.f @@ -1,7 +1,7 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zstemr.f b/SRC/zstemr.f index ea94ce71..fddd97e5 100644 --- a/SRC/zstemr.f +++ b/SRC/zstemr.f @@ -3,7 +3,7 @@ $ IWORK, LIWORK, INFO ) IMPLICIT NONE * -* -- LAPACK computational routine (version 3.1) -- +* -- LAPACK computational routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsteqr.f b/SRC/zsteqr.f index a72fdd96..1f266873 100644 --- a/SRC/zsteqr.f +++ b/SRC/zsteqr.f @@ -1,6 +1,6 @@ SUBROUTINE ZSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsycon.f b/SRC/zsycon.f index a9415423..e32a6776 100644 --- a/SRC/zsycon.f +++ b/SRC/zsycon.f @@ -1,7 +1,7 @@ SUBROUTINE ZSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsyequb.f b/SRC/zsyequb.f new file mode 100644 index 00000000..b46b760f --- /dev/null +++ b/SRC/zsyequb.f @@ -0,0 +1,256 @@ + SUBROUTINE ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + INTEGER INFO, LDA, N + DOUBLE PRECISION AMAX, SCOND + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), WORK( * ) + DOUBLE PRECISION S( * ) +* .. +* +* Purpose +* ======= +* +* ZSYEQUB computes row and column scalings intended to equilibrate a +* symmetric matrix A and reduce its condition number +* (with respect to the two-norm). S contains the scale factors, +* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with +* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This +* choice of S puts the condition number of B within a factor N of the +* smallest possible condition number over all possible diagonal +* scalings. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The N-by-N symmetric matrix whose scaling +* factors are to be computed. Only the diagonal elements of A +* are referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* S (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, S contains the scale factors for A. +* +* SCOND (output) DOUBLE PRECISION +* If INFO = 0, S contains the ratio of the smallest S(i) to +* the largest S(i). If SCOND >= 0.1 and AMAX is neither too +* large nor too small, it is not worth scaling by S. +* +* AMAX (output) DOUBLE PRECISION +* Absolute value of largest matrix element. If AMAX is very +* close to overflow or very close to underflow, the matrix +* should be scaled. +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the i-th diagonal element is nonpositive. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 ) + INTEGER MAX_ITER + PARAMETER ( MAX_ITER = 100 ) +* .. +* .. Local Scalars .. + INTEGER I, J, ITER + DOUBLE PRECISION AVG, STD, TOL, C0, C1, C2, T, U, SI, D, BASE, + $ SMIN, SMAX, SMLNUM, BIGNUM, SCALE, SUMSQ + LOGICAL UP + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + LOGICAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZLASSQ +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* Statement Function Definitions + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT. ( LSAME( UPLO, 'U' ) .OR. 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( 'ZSYEQUB', -INFO ) + RETURN + END IF + + UP = LSAME( UPLO, 'U' ) + AMAX = ZERO +* +* Quick return if possible. +* + IF ( N .EQ. 0 ) THEN + SCOND = ONE + RETURN + END IF + + DO I = 1, N + S( I ) = ZERO + END DO + + AMAX = ZERO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1( A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) + END DO + S( J ) = MAX( S( J ), CABS1( A( J, J) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + END DO + ELSE + DO J = 1, N + S( J ) = MAX( S( J ), CABS1( A( J, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( J, J ) ) ) + DO I = J+1, N + S( I ) = MAX( S( I ), CABS1( A( I, J ) ) ) + S( J ) = MAX( S( J ), CABS1 (A( I, J ) ) ) + AMAX = MAX( AMAX, CABS1( A( I, J ) ) ) + END DO + END DO + END IF + DO J = 1, N + S( J ) = 1.0D+0 / S( J ) + END DO + + TOL = ONE / SQRT( 2.0D0 * N ) + + DO ITER = 1, MAX_ITER + SCALE = 0.0D+0 + SUMSQ = 0.0D+0 +* beta = |A|s + DO I = 1, N + WORK( I ) = ZERO + END DO + IF ( UP ) THEN + DO J = 1, N + DO I = 1, J-1 + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + END DO + ELSE + DO J = 1, N + WORK( J ) = WORK( J ) + CABS1( A( J, J ) ) * S( J ) + DO I = J+1, N + T = CABS1( A( I, J ) ) + WORK( I ) = WORK( I ) + CABS1( A( I, J ) ) * S( J ) + WORK( J ) = WORK( J ) + CABS1( A( I, J ) ) * S( I ) + END DO + END DO + END IF + +* avg = s^T beta / n + AVG = 0.0D+0 + DO I = 1, N + AVG = AVG + S( I )*WORK( I ) + END DO + AVG = AVG / N + + STD = 0.0D+0 + DO I = 2*N+1, 3*N + WORK( I ) = S( I-2*N ) * WORK( I-2*N ) - AVG + END DO + CALL ZLASSQ( N, WORK( 2*N+1 ), 1, SCALE, SUMSQ ) + STD = SCALE * SQRT( SUMSQ / N ) + + IF ( STD .LT. TOL * AVG ) GOTO 999 + + DO I = 1, N + T = CABS1( A( I, I ) ) + SI = S( I ) + C2 = ( N-1 ) * T + C1 = ( N-2 ) * ( WORK( I ) - T*SI ) + C0 = -(T*SI)*SI + 2*WORK( I )*SI - N*AVG + D = C1*C1 - 4*C0*C2 + + IF ( D .LE. 0 ) THEN + INFO = -1 + RETURN + END IF + SI = -2*C0 / ( C1 + SQRT( D ) ) + + D = SI - S( I ) + U = ZERO + IF ( UP ) THEN + DO J = 1, I + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + ELSE + DO J = 1, I + T = CABS1( A( I, J ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + DO J = I+1,N + T = CABS1( A( J, I ) ) + U = U + S( J )*T + WORK( J ) = WORK( J ) + D*T + END DO + END IF + AVG = AVG + ( U + WORK( I ) ) * D / N + S( I ) = SI + END DO + END DO + + 999 CONTINUE + + SMLNUM = DLAMCH( 'SAFEMIN' ) + BIGNUM = ONE / SMLNUM + SMIN = BIGNUM + SMAX = ZERO + T = ONE / SQRT( AVG ) + BASE = DLAMCH( 'B' ) + U = ONE / LOG( BASE ) + DO I = 1, N + S( I ) = BASE ** INT( U * LOG( S( I ) * T ) ) + SMIN = MIN( SMIN, S( I ) ) + SMAX = MAX( SMAX, S( I ) ) + END DO + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) +* + END diff --git a/SRC/zsymv.f b/SRC/zsymv.f index 8d66ebe0..68d06800 100644 --- a/SRC/zsymv.f +++ b/SRC/zsymv.f @@ -1,6 +1,6 @@ SUBROUTINE ZSYMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * @@ -1,6 +1,6 @@ SUBROUTINE ZSYR( UPLO, N, ALPHA, X, INCX, A, LDA ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsyrfs.f b/SRC/zsyrfs.f index acfda2c8..90588e74 100644 --- a/SRC/zsyrfs.f +++ b/SRC/zsyrfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, $ X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsyrfsx.f b/SRC/zsyrfsx.f new file mode 100644 index 00000000..2d3698e6 --- /dev/null +++ b/SRC/zsyrfsx.f @@ -0,0 +1,575 @@ + Subroutine ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, + $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, + $ WORK, RWORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER UPLO, EQUED + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), RWORK( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ) +* .. +* +* Purpose +* ======= +* +* ZSYRFSX improves the computed solution to a system of linear +* equations when the coefficient matrix is symmetric indefinite, and +* provides error bounds and backward error estimates for the +* solution. In addition to normwise error bound, the code provides +* maximum componentwise error bound if possible. See comments for +* ERR_BNDS_N and ERR_BNDS_C for details of the error bounds. +* +* The original system of linear equations may have been equilibrated +* before calling this routine, as described by arguments EQUED and S +* below. In this case, the solution and error bounds returned are +* for the original unequilibrated system. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* EQUED (input) CHARACTER*1 +* Specifies the form of equilibration that was done to A +* before calling this routine. This is needed to compute +* the solution and error bounds correctly. +* = 'N': No equilibration +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* The right hand side B has been changed accordingly. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input) COMPLEX*16 array, dimension (LDAF,N) +* The factored form of the matrix A. AF contains the block +* diagonal matrix D and the multipliers used to obtain the +* factor U or L from the factorization A = U*D*U**T or A = +* L*D*L**T as computed by DSYTRF. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by DSYTRF. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input) COMPLEX*16 array, dimension (LDB,NRHS) +* The right hand side matrix B. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (input/output) COMPLEX*16 array, dimension (LDX,NRHS) +* On entry, the solution matrix X, as computed by DGETRS. +* On exit, the improved solution matrix X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the double-precision refinement algorithm, +* possibly with doubled-single computations if the +* compilation environment does not support DOUBLE +* PRECISION. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) +* +* IWORK (workspace) INTEGER array, dimension (N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT + DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT + DOUBLE PRECISION DZTHRESH_DEFAULT + PARAMETER ( ITREF_DEFAULT = 1.0D+0 ) + PARAMETER ( ITHRESH_DEFAULT = 10.0D+0 ) + PARAMETER ( COMPONENTWISE_DEFAULT = 1.0D+0 ) + PARAMETER ( RTHRESH_DEFAULT = 0.5D+0 ) + PARAMETER ( DZTHRESH_DEFAULT = 0.25D+0 ) + INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I, + $ LA_LINRX_CWISE_I + PARAMETER ( LA_LINRX_ITREF_I = 1, + $ LA_LINRX_ITHRESH_I = 2 ) + PARAMETER ( LA_LINRX_CWISE_I = 3 ) + INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I, + $ LA_LINRX_RCOND_I + PARAMETER ( LA_LINRX_TRUST_I = 1, LA_LINRX_ERR_I = 2 ) + PARAMETER ( LA_LINRX_RCOND_I = 3 ) + INTEGER LA_LINRX_MAX_N_ERRS + PARAMETER ( LA_LINRX_MAX_N_ERRS = 3 ) +* .. +* .. Local Scalars .. + CHARACTER(1) NORM + LOGICAL RCEQU + INTEGER J, PREC_TYPE, REF_TYPE + INTEGER N_NORMS + DOUBLE PRECISION ANORM, RCOND_TMP + DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG + LOGICAL IGNORE_CWISE + INTEGER ITHRESH + DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZSYCON, ZLA_SYRFSX_EXTENDED +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Functions .. + EXTERNAL LSAME, BLAS_FPINFO_X, ILATRANS, ILAPREC + EXTERNAL DLAMCH, ZLANSY, ZLA_SYRCOND_X, ZLA_SYRCOND_C + DOUBLE PRECISION DLAMCH, ZLANSY, ZLA_SYRCOND_X, ZLA_SYRCOND_C + LOGICAL LSAME + INTEGER BLAS_FPINFO_X + INTEGER ILATRANS, ILAPREC +* .. +* .. Executable Statements .. +* +* Check the input parameters. +* + INFO = 0 + REF_TYPE = INT( ITREF_DEFAULT ) + IF ( NPARAMS .GE. LA_LINRX_ITREF_I ) THEN + IF ( PARAMS( LA_LINRX_ITREF_I ) .LT. 0.0D+0 ) THEN + PARAMS( LA_LINRX_ITREF_I ) = ITREF_DEFAULT + ELSE + REF_TYPE = PARAMS( LA_LINRX_ITREF_I ) + END IF + END IF +* +* Set default parameters. +* + ILLRCOND_THRESH = DBLE( N ) * DLAMCH( 'Epsilon' ) + ITHRESH = INT( ITHRESH_DEFAULT ) + RTHRESH = RTHRESH_DEFAULT + UNSTABLE_THRESH = DZTHRESH_DEFAULT + IGNORE_CWISE = COMPONENTWISE_DEFAULT .EQ. 0.0D+0 +* + IF ( NPARAMS.GE.LA_LINRX_ITHRESH_I ) THEN + IF ( PARAMS( LA_LINRX_ITHRESH_I ).LT.0.0D+0 ) THEN + PARAMS( LA_LINRX_ITHRESH_I ) = ITHRESH + ELSE + ITHRESH = INT( PARAMS( LA_LINRX_ITHRESH_I ) ) + END IF + END IF + IF ( NPARAMS.GE.LA_LINRX_CWISE_I ) THEN + IF ( PARAMS( LA_LINRX_CWISE_I ).LT.0.0D+0 ) THEN + IF ( IGNORE_CWISE ) THEN + PARAMS( LA_LINRX_CWISE_I ) = 0.0D+0 + ELSE + PARAMS( LA_LINRX_CWISE_I ) = 1.0D+0 + END IF + ELSE + IGNORE_CWISE = PARAMS( LA_LINRX_CWISE_I ) .EQ. 0.0D+0 + END IF + END IF + IF ( REF_TYPE .EQ. 0 .OR. N_ERR_BNDS .EQ. 0 ) THEN + N_NORMS = 0 + ELSE IF ( IGNORE_CWISE ) THEN + N_NORMS = 1 + ELSE + N_NORMS = 2 + END IF +* + RCEQU = LSAME( EQUED, 'Y' ) +* +* Test input parameters. +* + IF ( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( .NOT.RCEQU .AND. .NOT.LSAME( EQUED, 'N' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -11 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYRFSX', -INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN + RCOND = 1.0D+0 + DO J = 1, NRHS + BERR( J ) = 0.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 0.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 1.0D+0 + END IF + END DO + RETURN + END IF +* +* Default to failure. +* + RCOND = 0.0D+0 + DO J = 1, NRHS + BERR( J ) = 1.0D+0 + IF ( N_ERR_BNDS .GE. 1 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 2 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ELSE IF ( N_ERR_BNDS .GE. 3 ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = 0.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = 0.0D+0 + END IF + END DO +* +* Compute the norm of A and the reciprocal of the condition +* number of A. +* + NORM = 'I' + ANORM = ZLANSY( NORM, UPLO, N, A, LDA, WORK ) + CALL ZSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, + $ INFO ) +* +* Perform refinement on each right-hand side +* + IF ( REF_TYPE .NE. 0 ) THEN + + PREC_TYPE = ILAPREC( 'E' ) + + CALL ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, + $ NRHS, A, LDA, AF, LDAF, IPIV, RCEQU, S, B, + $ LDB, X, LDX, BERR, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ WORK(N+1), RWORK, WORK(2*N+1), WORK(1), RCOND, + $ ITHRESH, RTHRESH, UNSTABLE_THRESH, IGNORE_CWISE, + $ INFO ) + END IF + + ERR_LBND = MAX( 10.0D+0, SQRT( DBLE( N ) ) ) * DLAMCH( 'Epsilon' ) + IF (N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 1) THEN +* +* Compute scaled normwise condition number cond(A*C). +* + IF ( RCEQU ) THEN + RCOND_TMP = ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .TRUE., INFO, WORK, RWORK ) + ELSE + RCOND_TMP = ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, LDAF, IPIV, + $ S, .FALSE., INFO, WORK, RWORK ) + END IF + DO J = 1, NRHS +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( INFO .LE. N ) INFO = N + J + ELSE IF ( ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) .LT. ERR_LBND ) + $ THEN + ERR_BNDS_NORM( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_NORM( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_NORM( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + END DO + END IF + + IF ( N_ERR_BNDS .GE. 1 .AND. N_NORMS .GE. 2 ) THEN +* +* Compute componentwise condition number cond(A*diag(Y(:,J))) for +* each right-hand side using the current solution as an estimate of +* the true solution. If the componentwise error estimate is too +* large, then the solution is a lousy estimate of truth and the +* estimated RCOND may be too optimistic. To avoid misleading users, +* the inverse condition number is set to 0.0 when the estimated +* cwise error is at least CWISE_WRONG. +* + CWISE_WRONG = SQRT( DLAMCH( 'Epsilon' ) ) + DO J = 1, NRHS + IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .LT. CWISE_WRONG ) + $ THEN + RCOND_TMP = ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, LDAF, + $ IPIV, X(1,J), INFO, WORK, RWORK ) + ELSE + RCOND_TMP = 0.0D+0 + END IF +* +* Cap the error at 1.0. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_ERR_I + $ .AND. ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) .GT. 1.0D+0 ) + $ ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + +* +* Threshold the error (see LAWN). +* + IF ( RCOND_TMP .LT. ILLRCOND_THRESH ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = 1.0D+0 + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 0.0D+0 + IF ( PARAMS( LA_LINRX_CWISE_I ) .EQ. 1.0D+0 + $ .AND. INFO.LT.N + J ) INFO = N + J + ELSE IF ( ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) + $ .LT. ERR_LBND ) THEN + ERR_BNDS_COMP( J, LA_LINRX_ERR_I ) = ERR_LBND + ERR_BNDS_COMP( J, LA_LINRX_TRUST_I ) = 1.0D+0 + END IF +* +* Save the condition number. +* + IF ( N_ERR_BNDS .GE. LA_LINRX_RCOND_I ) THEN + ERR_BNDS_COMP( J, LA_LINRX_RCOND_I ) = RCOND_TMP + END IF + + END DO + END IF +* + RETURN +* +* End of ZSYRFSX +* + END diff --git a/SRC/zsysv.f b/SRC/zsysv.f index 5b848bfa..042ba3e1 100644 --- a/SRC/zsysv.f +++ b/SRC/zsysv.f @@ -1,7 +1,7 @@ SUBROUTINE ZSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, $ LWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsysvx.f b/SRC/zsysvx.f index d9cbcd99..28a7bbb5 100644 --- a/SRC/zsysvx.f +++ b/SRC/zsysvx.f @@ -2,7 +2,7 @@ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, $ RWORK, INFO ) * -* -- LAPACK driver routine (version 3.1) -- +* -- LAPACK driver routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsysvxx.f b/SRC/zsysvxx.f new file mode 100644 index 00000000..cbdec3bf --- /dev/null +++ b/SRC/zsysvxx.f @@ -0,0 +1,559 @@ + SUBROUTINE ZSYSVXX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ EQUED, S, B, LDB, X, LDX, RCOND, RPVGRW, BERR, + $ N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, + $ NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* -- LAPACK driver routine (version 3.2) -- +* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- +* -- Jason Riedy of Univ. of California Berkeley. -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley and NAG Ltd. -- +* + IMPLICIT NONE +* .. +* .. Scalar Arguments .. + CHARACTER EQUED, FACT, UPLO + INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS, + $ N_ERR_BNDS + DOUBLE PRECISION RCOND, RPVGRW +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), + $ X( LDX, * ), WORK( * ) + DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ), + $ ERR_BNDS_NORM( NRHS, * ), + $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) +* .. +* +* Purpose +* ======= +* +* ZSYSVXX uses the diagonal pivoting factorization to compute the +* solution to a complex*16 system of linear equations A * X = B, where +* A is an N-by-N symmetric matrix and X and B are N-by-NRHS +* matrices. +* +* If requested, both normwise and maximum componentwise error bounds +* are returned. ZSYSVXX will return a solution with a tiny +* guaranteed error (O(eps) where eps is the working machine +* precision) unless the matrix is very ill-conditioned, in which +* case a warning is returned. Relevant condition numbers also are +* calculated and returned. +* +* ZSYSVXX accepts user-provided factorizations and equilibration +* factors; see the definitions of the FACT and EQUED options. +* Solving with refinement and using a factorization from a previous +* ZSYSVXX call will also produce a solution with either O(eps) +* errors or warnings, but we cannot make that claim for general +* user-provided factorizations and equilibration factors if they +* differ from what ZSYSVXX would itself produce. +* +* Description +* =========== +* +* The following steps are performed: +* +* 1. If FACT = 'E', double precision scaling factors are computed to equilibrate +* the system: +* +* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B +* +* Whether or not the system will be equilibrated depends on the +* scaling of the matrix A, but if equilibration is used, A is +* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. +* +* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor +* the matrix A (after equilibration if FACT = 'E') as +* +* A = U * D * U**T, if UPLO = 'U', or +* A = L * D * L**T, if UPLO = 'L', +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* 3. If some D(i,i)=0, so that D is exactly singular, then the +* routine returns with INFO = i. Otherwise, the factored form of A +* is used to estimate the condition number of the matrix A (see +* argument RCOND). If the reciprocal of the condition number is +* less than machine precision, the routine still goes on to solve +* for X and compute error bounds as described below. +* +* 4. The system of equations is solved for X using the factored form +* of A. +* +* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), +* the routine will use iterative refinement to try to get a small +* error and error bounds. Refinement calculates the residual to at +* least twice the working precision. +* +* 6. If equilibration was used, the matrix X is premultiplied by +* diag(R) so that it solves the original system before +* equilibration. +* +* Arguments +* ========= +* +* Some optional parameters are bundled in the PARAMS array. These +* settings determine how refinement is performed, but often the +* defaults are acceptable. If the defaults are acceptable, users +* can pass NPARAMS = 0 which prevents the source code from accessing +* the PARAMS argument. +* +* FACT (input) CHARACTER*1 +* Specifies whether or not the factored form of the matrix A is +* supplied on entry, and if not, whether the matrix A should be +* equilibrated before it is factored. +* = 'F': On entry, AF and IPIV contain the factored form of A. +* If EQUED is not 'N', the matrix A has been +* equilibrated with scaling factors given by S. +* A, AF, and IPIV are not modified. +* = 'N': The matrix A will be copied to AF and factored. +* = 'E': The matrix A will be equilibrated if necessary, then +* copied to AF and factored. +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrices B and X. NRHS >= 0. +* +* A (input/output) COMPLEX*16 array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading N-by-N +* upper triangular part of A contains the upper triangular +* part of the matrix A, and the strictly lower triangular +* part of A is not referenced. If UPLO = 'L', the leading +* N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by +* diag(S)*A*diag(S). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AF (input or output) COMPLEX*16 array, dimension (LDAF,N) +* If FACT = 'F', then AF is an input argument and on entry +* contains the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T as computed by DSYTRF. +* +* If FACT = 'N', then AF is an output argument and on exit +* returns the block diagonal matrix D and the multipliers +* used to obtain the factor U or L from the factorization A = +* U*D*U**T or A = L*D*L**T. +* +* LDAF (input) INTEGER +* The leading dimension of the array AF. LDAF >= max(1,N). +* +* IPIV (input or output) INTEGER array, dimension (N) +* If FACT = 'F', then IPIV is an input argument and on entry +* contains details of the interchanges and the block +* structure of D, as determined by DSYTRF. If IPIV(k) > 0, +* then rows and columns k and IPIV(k) were interchanged and +* D(k,k) is a 1-by-1 diagonal block. If UPLO = 'U' and +* IPIV(k) = IPIV(k-1) < 0, then rows and columns k-1 and +* -IPIV(k) were interchanged and D(k-1:k,k-1:k) is a 2-by-2 +* diagonal block. If UPLO = 'L' and IPIV(k) = IPIV(k+1) < 0, +* then rows and columns k+1 and -IPIV(k) were interchanged +* and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* If FACT = 'N', then IPIV is an output argument and on exit +* contains details of the interchanges and the block +* structure of D, as determined by DSYTRF. +* +* EQUED (input or output) CHARACTER*1 +* Specifies the form of equilibration that was done. +* = 'N': No equilibration (always true if FACT = 'N'). +* = 'Y': Both row and column equilibration, i.e., A has been +* replaced by diag(S) * A * diag(S). +* EQUED is an input argument if FACT = 'F'; otherwise, it is an +* output argument. +* +* S (input or output) DOUBLE PRECISION array, dimension (N) +* The scale factors for A. If EQUED = 'Y', A is multiplied on +* the left and right by diag(S). S is an input argument if FACT = +* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED +* = 'Y', each element of S must be positive. If S is output, each +* element of S is a power of the radix. If S is input, each element +* of S should be a power of the radix to ensure a reliable solution +* and error estimates. Scaling by powers of the radix does not cause +* rounding errors unless the result underflows or overflows. +* Rounding errors during scaling lead to refining with a matrix that +* is not equivalent to the input matrix, producing error estimates +* that may not be reliable. +* +* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS right hand side matrix B. +* On exit, +* if EQUED = 'N', B is not modified; +* if EQUED = 'Y', B is overwritten by diag(S)*B; +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* X (output) COMPLEX*16 array, dimension (LDX,NRHS) +* If INFO = 0, the N-by-NRHS solution matrix X to the original +* system of equations. Note that A and B are modified on exit if +* EQUED .ne. 'N', and the solution to the equilibrated system is +* inv(diag(S))*X. +* +* LDX (input) INTEGER +* The leading dimension of the array X. LDX >= max(1,N). +* +* RCOND (output) DOUBLE PRECISION +* Reciprocal scaled condition number. This is an estimate of the +* reciprocal Skeel condition number of the matrix A after +* equilibration (if done). If this is less than the machine +* precision (in particular, if it is zero), the matrix is singular +* to working precision. Note that the error may still be small even +* if this number is very small and the matrix appears ill- +* conditioned. +* +* RPVGRW (output) DOUBLE PRECISION +* Reciprocal pivot growth. On exit, this contains the reciprocal +* pivot growth factor norm(A)/norm(U). The "max absolute element" +* norm is used. If this is much less than 1, then the stability of +* the LU factorization of the (equilibrated) matrix A could be poor. +* This also means that the solution X, estimated condition numbers, +* and error bounds could be unreliable. If factorization fails with +* 0<INFO<=N, then this contains the reciprocal pivot growth factor +* for the leading INFO columns of A. +* +* BERR (output) DOUBLE PRECISION array, dimension (NRHS) +* Componentwise relative backward error. This is the +* componentwise relative backward error of each solution vector X(j) +* (i.e., the smallest relative change in any element of A or B that +* makes X(j) an exact solution). +* +* N_ERR_BNDS (input) INTEGER +* Number of error bounds to return for each right hand side +* and each type (normwise or componentwise). See ERR_BNDS_NORM and +* ERR_BNDS_COMP below. +* +* ERR_BNDS_NORM (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* normwise relative error, which is defined as follows: +* +* Normwise relative error in the ith solution vector: +* max_j (abs(XTRUE(j,i) - X(j,i))) +* ------------------------------ +* max_j abs(X(j,i)) +* +* The array is indexed by the type of error information as described +* below. There currently are up to three pieces of information +* returned. +* +* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_NORM(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated normwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*A, where S scales each row by a power of the +* radix so all absolute row sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* ERR_BNDS_COMP (output) DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) +* For each right-hand side, this array contains information about +* various error bounds and condition numbers corresponding to the +* componentwise relative error, which is defined as follows: +* +* Componentwise relative error in the ith solution vector: +* abs(XTRUE(j,i) - X(j,i)) +* max_j ---------------------- +* abs(X(j,i)) +* +* The array is indexed by the right-hand side i (on which the +* componentwise relative error depends), and the type of error +* information as described below. There currently are up to three +* pieces of information returned for each right-hand side. If +* componentwise accuracy is not requested (PARAMS(3) = 0.0), then +* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most +* the first (:,N_ERR_BNDS) entries are returned. +* +* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith +* right-hand side. +* +* The second index in ERR_BNDS_COMP(:,err) contains the following +* three fields: +* err = 1 "Trust/don't trust" boolean. Trust the answer if the +* reciprocal condition number is less than the threshold +* sqrt(n) * dlamch('Epsilon'). +* +* err = 2 "Guaranteed" error bound: The estimated forward error, +* almost certainly within a factor of 10 of the true error +* so long as the next entry is greater than the threshold +* sqrt(n) * dlamch('Epsilon'). This error bound should only +* be trusted if the previous boolean is true. +* +* err = 3 Reciprocal condition number: Estimated componentwise +* reciprocal condition number. Compared with the threshold +* sqrt(n) * dlamch('Epsilon') to determine if the error +* estimate is "guaranteed". These reciprocal condition +* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some +* appropriately scaled matrix Z. +* Let Z = S*(A*diag(x)), where x is the solution for the +* current right-hand side and S scales each row of +* A*diag(x) by a power of the radix so all absolute row +* sums of Z are approximately 1. +* +* See Lapack Working Note 165 for further details and extra +* cautions. +* +* NPARAMS (input) INTEGER +* Specifies the number of parameters set in PARAMS. If .LE. 0, the +* PARAMS array is never referenced and default values are used. +* +* PARAMS (input / output) DOUBLE PRECISION array, dimension NPARAMS +* Specifies algorithm parameters. If an entry is .LT. 0.0, then +* that entry will be filled with default value used for that +* parameter. Only positions up to NPARAMS are accessed; defaults +* are used for higher-numbered parameters. +* +* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative +* refinement or not. +* Default: 1.0D+0 +* = 0.0 : No refinement is performed, and no error bounds are +* computed. +* = 1.0 : Use the extra-precise refinement algorithm. +* (other values are reserved for future use) +* +* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual +* computations allowed for refinement. +* Default: 10 +* Aggressive: Set to 100 to permit convergence using approximate +* factorizations or factorizations other than LU. If +* the factorization uses a technique other than +* Gaussian elimination, the guarantees in +* err_bnds_norm and err_bnds_comp may no longer be +* trustworthy. +* +* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code +* will attempt to find a solution with small componentwise +* relative error in the double-precision algorithm. Positive +* is true, 0.0 is false. +* Default: 1.0 (attempt componentwise convergence) +* +* WORK (workspace) COMPLEX*16 array, dimension (2*N) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (3*N) +* +* INFO (output) INTEGER +* = 0: Successful exit. The solution to every right-hand side is +* guaranteed. +* < 0: If INFO = -i, the i-th argument had an illegal value +* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization +* has been completed, but the factor U is exactly singular, so +* the solution and error bounds could not be computed. RCOND = 0 +* is returned. +* = N+J: The solution corresponding to the Jth right-hand side is +* not guaranteed. The solutions corresponding to other right- +* hand sides K with K > J may not be guaranteed as well, but +* only the first such right-hand side is reported. If a small +* componentwise error is not requested (PARAMS(3) = 0.0) then +* the Jth right-hand side is the first with a normwise error +* bound that is not guaranteed (the smallest J such +* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) +* the Jth right-hand side is the first with either a normwise or +* componentwise error bound that is not guaranteed (the smallest +* J such that either ERR_BNDS_NORM(J,1) = 0.0 or +* ERR_BNDS_COMP(J,1) = 0.0). See the definition of +* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information +* about all of the right-hand sides check ERR_BNDS_NORM or +* ERR_BNDS_COMP. +* +* ================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I + INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I + INTEGER CMP_ERR_I, PIV_GROWTH_I + PARAMETER ( FINAL_NRM_ERR_I = 1, FINAL_CMP_ERR_I = 2, + $ BERR_I = 3 ) + PARAMETER ( RCOND_I = 4, NRM_RCOND_I = 5, NRM_ERR_I = 6 ) + PARAMETER ( CMP_RCOND_I = 7, CMP_ERR_I = 8, + $ PIV_GROWTH_I = 9 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, RCEQU + INTEGER INFEQU, J + DOUBLE PRECISION AMAX, BIGNUM, SMIN, SMAX, SCOND, SMLNUM +* .. +* .. External Functions .. + EXTERNAL LSAME, DLAMCH, ZLA_SYRPVGRW + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLA_SYRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ZSYCON, ZSYEQUB, ZSYTRF, ZSYTRS, ZLACPY, + $ ZLAQSY, XERBLA, ZLASCL2, ZSYRFSX +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) + SMLNUM = DLAMCH( 'Safe minimum' ) + BIGNUM = ONE / SMLNUM + IF( NOFACT .OR. EQUIL ) THEN + EQUED = 'N' + RCEQU = .FALSE. + ELSE + RCEQU = LSAME( EQUED, 'Y' ) + ENDIF +* +* Default is failure. If an input parameter is wrong or +* factorization fails, make everything look horrible. Only the +* pivot growth is set here, the rest is initialized in ZSYRFSX. +* + RPVGRW = ZERO +* +* Test the input parameters. PARAMS is not tested until ZSYRFSX. +* + IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT. + $ LSAME( FACT, 'F' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSAME(UPLO, 'U') .AND. + $ .NOT.LSAME(UPLO, 'L') ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN + INFO = -8 + ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT. + $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN + INFO = -9 + ELSE + IF ( RCEQU ) THEN + SMIN = BIGNUM + SMAX = ZERO + DO 10 J = 1, N + SMIN = MIN( SMIN, S( J ) ) + SMAX = MAX( SMAX, S( J ) ) + 10 CONTINUE + IF( SMIN.LE.ZERO ) THEN + INFO = -10 + ELSE IF( N.GT.0 ) THEN + SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM ) + ELSE + SCOND = ONE + END IF + END IF + IF( INFO.EQ.0 ) THEN + IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -12 + ELSE IF( LDX.LT.MAX( 1, N ) ) THEN + INFO = -14 + END IF + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZSYSVXX', -INFO ) + RETURN + END IF +* + IF( EQUIL ) THEN +* +* Compute row and column scalings to equilibrate the matrix A. +* + CALL ZSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFEQU ) + IF( INFEQU.EQ.0 ) THEN +* +* Equilibrate the matrix. +* + CALL ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) + RCEQU = LSAME( EQUED, 'Y' ) + END IF + + END IF +* +* Scale the right hand-side. +* + IF( RCEQU ) CALL ZLASCL2( N, NRHS, S, B, LDB ) +* + IF( NOFACT .OR. EQUIL ) THEN +* +* Compute the LU factorization of A. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AF, LDAF ) + CALL ZSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, 5*MAX(1,N), INFO ) +* +* Return if INFO is non-zero. +* + IF( INFO.GT.0 ) THEN +* +* Pivot in column INFO is exactly 0 +* Compute the reciprocal pivot growth factor of the +* leading rank-deficient INFO columns of A. +* + IF ( N.GT.0 ) + $ RPVGRW = ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, + $ LDAF, IPIV, WORK ) + RETURN + END IF + END IF +* +* Compute the reciprocal pivot growth factor RPVGRW. +* + IF ( N.GT.0 ) + $ RPVGRW = ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, LDAF, + $ IPIV, WORK ) +* +* Compute the solution matrix X. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDX ) + CALL ZSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO ) +* +* Use iterative refinement to improve the computed solution and +* compute error bounds and backward error estimates for it. +* + CALL ZSYRFSX( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, + $ S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, + $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO ) +* +* Scale solutions. +* + IF ( RCEQU ) THEN + CALL ZLASCL2 (N, NRHS, S, X, LDX ) + END IF +* + RETURN +* +* End of ZSYSVXX +* + END diff --git a/SRC/zsytf2.f b/SRC/zsytf2.f index 7c0a0ce8..fa8a8bf9 100644 --- a/SRC/zsytf2.f +++ b/SRC/zsytf2.f @@ -1,6 +1,6 @@ SUBROUTINE ZSYTF2( UPLO, N, A, LDA, IPIV, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsytrf.f b/SRC/zsytrf.f index 2c020801..a8fa4140 100644 --- a/SRC/zsytrf.f +++ b/SRC/zsytrf.f @@ -1,6 +1,6 @@ SUBROUTINE ZSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsytri.f b/SRC/zsytri.f index 813b41d2..60edb6cc 100644 --- a/SRC/zsytri.f +++ b/SRC/zsytri.f @@ -1,6 +1,6 @@ SUBROUTINE ZSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zsytrs.f b/SRC/zsytrs.f index 3b2bbb46..4dca6cf1 100644 --- a/SRC/zsytrs.f +++ b/SRC/zsytrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztbcon.f b/SRC/ztbcon.f index 2d94db4a..02d814bc 100644 --- a/SRC/ztbcon.f +++ b/SRC/ztbcon.f @@ -1,7 +1,7 @@ SUBROUTINE ZTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztbrfs.f b/SRC/ztbrfs.f index 91d73483..7bc74522 100644 --- a/SRC/ztbrfs.f +++ b/SRC/ztbrfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztbtrs.f b/SRC/ztbtrs.f index 7e9ab0bc..d81a4950 100644 --- a/SRC/ztbtrs.f +++ b/SRC/ztbtrs.f @@ -1,7 +1,7 @@ SUBROUTINE ZTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, $ LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztfsm.f b/SRC/ztfsm.f new file mode 100644 index 00000000..ab409b28 --- /dev/null +++ b/SRC/ztfsm.f @@ -0,0 +1,922 @@ + SUBROUTINE ZTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, + + B, LDB ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO + INTEGER LDB, M, N + COMPLEX*16 ALPHA +* .. +* .. Array Arguments .. + COMPLEX*16 A( 0: * ), B( 0: LDB-1, 0: * ) +* .. +* +* Purpose +* ======= +* +* Level 3 BLAS like routine for A in RFP Format. +* +* ZTFSM solves the matrix equation +* +* op( A )*X = alpha*B or X*op( A ) = alpha*B +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = conjg( A' ). +* +* A is in Rectangular Full Packed (RFP) Format. +* +* The matrix X is overwritten on B. +* +* Arguments +* ========== +* +* TRANSR - (input) CHARACTER +* = 'N': The Normal Form of RFP A is stored; +* = 'C': The Conjugate-transpose Form of RFP A is stored. +* +* SIDE - (input) CHARACTER +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* Unchanged on exit. +* +* UPLO - (input) CHARACTER +* On entry, UPLO specifies whether the RFP matrix A came from +* an upper or lower triangular matrix as follows: +* UPLO = 'U' or 'u' RFP A came from an upper triangular matrix +* UPLO = 'L' or 'l' RFP A came from a lower triangular matrix +* +* Unchanged on exit. +* +* TRANS - (input) CHARACTER +* On entry, TRANS specifies the form of op( A ) to be used +* in the matrix multiplication as follows: +* +* TRANS = 'N' or 'n' op( A ) = A. +* +* TRANS = 'C' or 'c' op( A ) = conjg( A' ). +* +* Unchanged on exit. +* +* DIAG - (input) CHARACTER +* On entry, DIAG specifies whether or not RFP A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - (input) INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - (input) INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - (input) COMPLEX*16. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ); +* NT = N*(N+1)/2. On entry, the matrix A in RFP Format. +* RFP Format is described by TRANSR, UPLO and N as follows: +* If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; +* K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If +* TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A as +* defined when TRANSR = 'N'. The contents of RFP A are defined +* by UPLO as follows: If UPLO = 'U' the RFP A contains the NT +* elements of upper packed A either in normal or +* conjugate-transpose Format. If UPLO = 'L' the RFP A contains +* the NT elements of lower packed A either in normal or +* conjugate-transpose Format. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is +* even and is N when is odd. +* See the Note below for more details. Unchanged on exit. +* +* B - (input/ouptut) COMPLEX*16 array, DIMENSION ( LDB, N) +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB - (input) INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* .. +* .. Parameters .. + COMPLEX*16 CONE, CZERO + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ), + + CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LSIDE, MISODD, NISODD, NORMALTRANSR, + + NOTRANS + INTEGER M1, M2, N1, N2, K, INFO, I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZGEMM, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LSIDE = LSAME( SIDE, 'L' ) + LOWER = LSAME( UPLO, 'L' ) + NOTRANS = LSAME( TRANS, 'N' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LSIDE .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -3 + ELSE IF( .NOT.NOTRANS .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -4 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -5 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 ) THEN + INFO = -7 + ELSE IF( LDB.LT.MAX( 1, M ) ) THEN + INFO = -11 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTFSM ', -INFO ) + RETURN + END IF +* +* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + + RETURN +* +* Quick return when ALPHA.EQ.(0D+0,0D+0) +* + IF( ALPHA.EQ.CZERO ) THEN + DO 20 J = 0, N - 1 + DO 10 I = 0, M - 1 + B( I, J ) = CZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* + IF( LSIDE ) THEN +* +* SIDE = 'L' +* +* A is M-by-M. +* If M is odd, set NISODD = .TRUE., and M1 and M2. +* If M is even, NISODD = .FALSE., and M. +* + IF( MOD( M, 2 ).EQ.0 ) THEN + MISODD = .FALSE. + K = M / 2 + ELSE + MISODD = .TRUE. + IF( LOWER ) THEN + M2 = M / 2 + M1 = M - M2 + ELSE + M1 = M / 2 + M2 = M - M1 + END IF + END IF +* + IF( MISODD ) THEN +* +* SIDE = 'L' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL ZTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( 0 ), M, B, LDB ) + CALL ZGEMM( 'N', 'N', M2, N, M1, -CONE, A( M1 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL ZTRSM( 'L', 'U', 'C', DIAG, M2, N, CONE, + + A( M ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'C' +* + CALL ZTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M ), M, B( M1, 0 ), LDB ) + CALL ZGEMM( 'C', 'N', M1, N, M2, -CONE, A( M1 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'L', 'C', DIAG, M1, N, CONE, + + A( 0 ), M, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL ZTRSM( 'L', 'L', 'N', DIAG, M1, N, ALPHA, + + A( M2 ), M, B, LDB ) + CALL ZGEMM( 'C', 'N', M2, N, M1, -CONE, A( 0 ), M, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL ZTRSM( 'L', 'U', 'C', DIAG, M2, N, CONE, + + A( M1 ), M, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'C' +* + CALL ZTRSM( 'L', 'U', 'N', DIAG, M2, N, ALPHA, + + A( M1 ), M, B( M1, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', M1, N, M2, -CONE, A( 0 ), M, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'L', 'C', DIAG, M1, N, CONE, + + A( M2 ), M, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is odd, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'N' +* + CALL ZTRSM( 'L', 'U', 'C', DIAG, M1, N, ALPHA, + + A( 0 ), M1, B, LDB ) + CALL ZGEMM( 'C', 'N', M2, N, M1, -CONE, A( M1*M1 ), + + M1, B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL ZTRSM( 'L', 'L', 'N', DIAG, M2, N, CONE, + + A( 1 ), M1, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'C' +* + CALL ZTRSM( 'L', 'L', 'C', DIAG, M2, N, ALPHA, + + A( 1 ), M1, B( M1, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', M1, N, M2, -CONE, A( M1*M1 ), + + M1, B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'U', 'N', DIAG, M1, N, CONE, + + A( 0 ), M1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'C', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'N' +* + CALL ZTRSM( 'L', 'U', 'C', DIAG, M1, N, ALPHA, + + A( M2*M2 ), M2, B, LDB ) + CALL ZGEMM( 'N', 'N', M2, N, M1, -CONE, A( 0 ), M2, + + B, LDB, ALPHA, B( M1, 0 ), LDB ) + CALL ZTRSM( 'L', 'L', 'N', DIAG, M2, N, CONE, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'C' +* + CALL ZTRSM( 'L', 'L', 'C', DIAG, M2, N, ALPHA, + + A( M1*M2 ), M2, B( M1, 0 ), LDB ) + CALL ZGEMM( 'C', 'N', M1, N, M2, -CONE, A( 0 ), M2, + + B( M1, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'U', 'N', DIAG, M1, N, CONE, + + A( M2*M2 ), M2, B, LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'L', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL ZTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( 1 ), M+1, B, LDB ) + CALL ZGEMM( 'N', 'N', K, N, K, -CONE, A( K+1 ), + + M+1, B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL ZTRSM( 'L', 'U', 'C', DIAG, K, N, CONE, + + A( 0 ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'C' +* + CALL ZTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( 0 ), M+1, B( K, 0 ), LDB ) + CALL ZGEMM( 'C', 'N', K, N, K, -CONE, A( K+1 ), + + M+1, B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'L', 'C', DIAG, K, N, CONE, + + A( 1 ), M+1, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL ZTRSM( 'L', 'L', 'N', DIAG, K, N, ALPHA, + + A( K+1 ), M+1, B, LDB ) + CALL ZGEMM( 'C', 'N', K, N, K, -CONE, A( 0 ), M+1, + + B, LDB, ALPHA, B( K, 0 ), LDB ) + CALL ZTRSM( 'L', 'U', 'C', DIAG, K, N, CONE, + + A( K ), M+1, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'C' + CALL ZTRSM( 'L', 'U', 'N', DIAG, K, N, ALPHA, + + A( K ), M+1, B( K, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', K, N, K, -CONE, A( 0 ), M+1, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'L', 'C', DIAG, K, N, CONE, + + A( K+1 ), M+1, B, LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'L', N is even, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'N' +* + CALL ZTRSM( 'L', 'U', 'C', DIAG, K, N, ALPHA, + + A( K ), K, B, LDB ) + CALL ZGEMM( 'C', 'N', K, N, K, -CONE, + + A( K*( K+1 ) ), K, B, LDB, ALPHA, + + B( K, 0 ), LDB ) + CALL ZTRSM( 'L', 'L', 'N', DIAG, K, N, CONE, + + A( 0 ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'C' +* + CALL ZTRSM( 'L', 'L', 'C', DIAG, K, N, ALPHA, + + A( 0 ), K, B( K, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', K, N, K, -CONE, + + A( K*( K+1 ) ), K, B( K, 0 ), LDB, + + ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'U', 'N', DIAG, K, N, CONE, + + A( K ), K, B, LDB ) +* + END IF +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'C', and UPLO = 'U' +* + IF( .NOT.NOTRANS ) THEN +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'N' +* + CALL ZTRSM( 'L', 'U', 'C', DIAG, K, N, ALPHA, + + A( K*( K+1 ) ), K, B, LDB ) + CALL ZGEMM( 'N', 'N', K, N, K, -CONE, A( 0 ), K, B, + + LDB, ALPHA, B( K, 0 ), LDB ) + CALL ZTRSM( 'L', 'L', 'N', DIAG, K, N, CONE, + + A( K*K ), K, B( K, 0 ), LDB ) +* + ELSE +* +* SIDE ='L', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'C' +* + CALL ZTRSM( 'L', 'L', 'C', DIAG, K, N, ALPHA, + + A( K*K ), K, B( K, 0 ), LDB ) + CALL ZGEMM( 'C', 'N', K, N, K, -CONE, A( 0 ), K, + + B( K, 0 ), LDB, ALPHA, B, LDB ) + CALL ZTRSM( 'L', 'U', 'N', DIAG, K, N, CONE, + + A( K*( K+1 ) ), K, B, LDB ) +* + END IF +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' +* +* A is N-by-N. +* If N is odd, set NISODD = .TRUE., and N1 and N2. +* If N is even, NISODD = .FALSE., and K. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + NISODD = .FALSE. + K = N / 2 + ELSE + NISODD = .TRUE. + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF + END IF +* + IF( NISODD ) THEN +* +* SIDE = 'R' and N is odd +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is odd, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'N' +* + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, N2, ALPHA, + + A( N ), N, B( 0, N1 ), LDB ) + CALL ZGEMM( 'N', 'N', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( N1 ), N, ALPHA, B( 0, 0 ), + + LDB ) + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, N1, CONE, + + A( 0 ), N, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and +* TRANS = 'C' +* + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, N1, ALPHA, + + A( 0 ), N, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'C', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( N1 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, N2, CONE, + + A( N ), N, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'N' +* + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, N1, ALPHA, + + A( N2 ), N, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( 0 ), N, ALPHA, B( 0, N1 ), + + LDB ) + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, N2, CONE, + + A( N1 ), N, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and +* TRANS = 'C' +* + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, N2, ALPHA, + + A( N1 ), N, B( 0, N1 ), LDB ) + CALL ZGEMM( 'N', 'C', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( 0 ), N, ALPHA, B( 0, 0 ), LDB ) + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, N1, CONE, + + A( N2 ), N, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is odd, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'N' +* + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( 1 ), N1, B( 0, N1 ), LDB ) + CALL ZGEMM( 'N', 'C', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, 0 ), + + LDB ) + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, N1, CONE, + + A( 0 ), N1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'L', and +* TRANS = 'C' +* + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( 0 ), N1, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( N1*N1 ), N1, ALPHA, B( 0, N1 ), + + LDB ) + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, N2, CONE, + + A( 1 ), N1, B( 0, N1 ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'N' +* + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, N1, ALPHA, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'C', M, N2, N1, -CONE, B( 0, 0 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, N1 ), + + LDB ) + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, N2, CONE, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) +* + ELSE +* +* SIDE ='R', N is odd, TRANSR = 'C', UPLO = 'U', and +* TRANS = 'C' +* + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, N2, ALPHA, + + A( N1*N2 ), N2, B( 0, N1 ), LDB ) + CALL ZGEMM( 'N', 'N', M, N1, N2, -CONE, B( 0, N1 ), + + LDB, A( 0 ), N2, ALPHA, B( 0, 0 ), + + LDB ) + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, N1, CONE, + + A( N2*N2 ), N2, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R' and N is even +* + IF( NORMALTRANSR ) THEN +* +* SIDE = 'R', N is even, and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'N' +* + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, K, ALPHA, + + A( 0 ), N+1, B( 0, K ), LDB ) + CALL ZGEMM( 'N', 'N', M, K, K, -CONE, B( 0, K ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, K, CONE, + + A( 1 ), N+1, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', +* and TRANS = 'C' +* + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, K, ALPHA, + + A( 1 ), N+1, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'C', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( K+1 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, K, CONE, + + A( 0 ), N+1, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'N' +* + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, K, ALPHA, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, K ), + + LDB ) + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, K, CONE, + + A( K ), N+1, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', +* and TRANS = 'C' +* + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, K, ALPHA, + + A( K ), N+1, B( 0, K ), LDB ) + CALL ZGEMM( 'N', 'C', M, K, K, -CONE, B( 0, K ), + + LDB, A( 0 ), N+1, ALPHA, B( 0, 0 ), + + LDB ) + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, K, CONE, + + A( K+1 ), N+1, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + ELSE +* +* SIDE = 'R', N is even, and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'L' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'N' +* + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( 0 ), K, B( 0, K ), LDB ) + CALL ZGEMM( 'N', 'C', M, K, K, -CONE, B( 0, K ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, 0 ), LDB ) + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, K, CONE, + + A( K ), K, B( 0, 0 ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'L', +* and TRANS = 'C' +* + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( K ), K, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'N', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( ( K+1 )*K ), K, ALPHA, + + B( 0, K ), LDB ) + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, K, CONE, + + A( 0 ), K, B( 0, K ), LDB ) +* + END IF +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'C', and UPLO = 'U' +* + IF( NOTRANS ) THEN +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'N' +* + CALL ZTRSM( 'R', 'U', 'N', DIAG, M, K, ALPHA, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) + CALL ZGEMM( 'N', 'C', M, K, K, -CONE, B( 0, 0 ), + + LDB, A( 0 ), K, ALPHA, B( 0, K ), LDB ) + CALL ZTRSM( 'R', 'L', 'C', DIAG, M, K, CONE, + + A( K*K ), K, B( 0, K ), LDB ) +* + ELSE +* +* SIDE ='R', N is even, TRANSR = 'C', UPLO = 'U', +* and TRANS = 'C' +* + CALL ZTRSM( 'R', 'L', 'N', DIAG, M, K, ALPHA, + + A( K*K ), K, B( 0, K ), LDB ) + CALL ZGEMM( 'N', 'N', M, K, K, -CONE, B( 0, K ), + + LDB, A( 0 ), K, ALPHA, B( 0, 0 ), LDB ) + CALL ZTRSM( 'R', 'U', 'C', DIAG, M, K, CONE, + + A( ( K+1 )*K ), K, B( 0, 0 ), LDB ) +* + END IF +* + END IF +* + END IF +* + END IF + END IF +* + RETURN +* +* End of ZTFSM +* + END diff --git a/SRC/ztftri.f b/SRC/ztftri.f new file mode 100644 index 00000000..1fc7c304 --- /dev/null +++ b/SRC/ztftri.f @@ -0,0 +1,427 @@ + SUBROUTINE ZTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO, DIAG + INTEGER INFO, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( 0: * ) +* .. +* +* Purpose +* ======= +* +* ZTFTRI computes the inverse of a triangular matrix A stored in RFP +* format. +* +* This is a Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': The Normal TRANSR of RFP A is stored; +* = 'C': The Conjugate-transpose TRANSR of RFP A is stored. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* DIAG (input) CHARACTER +* = 'N': A is non-unit triangular; +* = 'U': A is unit triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) COMPLEX*16 array, dimension ( N*(N+1)/2 ); +* On entry, the triangular matrix A in RFP format. RFP format +* is described by TRANSR, UPLO, and N as follows: If TRANSR = +* 'N' then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is +* (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is +* the Conjugate-transpose of RFP A as defined when +* TRANSR = 'N'. The contents of RFP A are defined by UPLO as +* follows: If UPLO = 'U' the RFP A contains the nt elements of +* upper packed A; If UPLO = 'L' the RFP A contains the nt +* elements of lower packed A. The LDA of RFP A is (N+1)/2 when +* TRANSR = 'C'. When TRANSR is 'N' the LDA is N+1 when N is +* even and N is odd. See the Note below for more details. +* +* On exit, the (triangular) inverse of the original matrix, in +* the same storage format. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, A(i,i) is exactly zero. The triangular +* matrix is singular and its inverse can not be computed. +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 CONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZTRMM, ZTRTRI +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( DIAG, 'N' ) .AND. .NOT.LSAME( DIAG, 'U' ) ) + + THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTFTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + ELSE + NISODD = .TRUE. + END IF +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1) +* + CALL ZTRTRI( 'L', DIAG, N1, A( 0 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'L', 'N', DIAG, N2, N1, -CONE, A( 0 ), + + N, A( N1 ), N ) + CALL ZTRTRI( 'U', DIAG, N2, A( N ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'U', 'C', DIAG, N2, N1, CONE, A( N ), N, + + A( N1 ), N ) +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + CALL ZTRTRI( 'L', DIAG, N1, A( N2 ), N, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'L', 'C', DIAG, N1, N2, -CONE, A( N2 ), + + N, A( 0 ), N ) + CALL ZTRTRI( 'U', DIAG, N2, A( N1 ), N, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'U', 'N', DIAG, N1, N2, CONE, A( N1 ), + + N, A( 0 ), N ) +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) +* + CALL ZTRTRI( 'U', DIAG, N1, A( 0 ), N1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'U', 'N', DIAG, N1, N2, -CONE, A( 0 ), + + N1, A( N1*N1 ), N1 ) + CALL ZTRTRI( 'L', DIAG, N2, A( 1 ), N1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'L', 'C', DIAG, N1, N2, CONE, A( 1 ), + + N1, A( N1*N1 ), N1 ) +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) +* + CALL ZTRTRI( 'U', DIAG, N1, A( N2*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'U', 'C', DIAG, N2, N1, -CONE, + + A( N2*N2 ), N2, A( 0 ), N2 ) + CALL ZTRTRI( 'L', DIAG, N2, A( N1*N2 ), N2, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + N1 + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'L', 'N', DIAG, N2, N1, CONE, + + A( N1*N2 ), N2, A( 0 ), N2 ) + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + CALL ZTRTRI( 'L', DIAG, K, A( 1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'L', 'N', DIAG, K, K, -CONE, A( 1 ), + + N+1, A( K+1 ), N+1 ) + CALL ZTRTRI( 'U', DIAG, K, A( 0 ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'U', 'C', DIAG, K, K, CONE, A( 0 ), N+1, + + A( K+1 ), N+1 ) +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + CALL ZTRTRI( 'L', DIAG, K, A( K+1 ), N+1, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'L', 'C', DIAG, K, K, -CONE, A( K+1 ), + + N+1, A( 0 ), N+1 ) + CALL ZTRTRI( 'U', DIAG, K, A( K ), N+1, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'U', 'N', DIAG, K, K, CONE, A( K ), N+1, + + A( 0 ), N+1 ) + END IF + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + CALL ZTRTRI( 'U', DIAG, K, A( K ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'U', 'N', DIAG, K, K, -CONE, A( K ), K, + + A( K*( K+1 ) ), K ) + CALL ZTRTRI( 'L', DIAG, K, A( 0 ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'L', 'C', DIAG, K, K, CONE, A( 0 ), K, + + A( K*( K+1 ) ), K ) + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + CALL ZTRTRI( 'U', DIAG, K, A( K*( K+1 ) ), K, INFO ) + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'R', 'U', 'C', DIAG, K, K, -CONE, + + A( K*( K+1 ) ), K, A( 0 ), K ) + CALL ZTRTRI( 'L', DIAG, K, A( K*K ), K, INFO ) + IF( INFO.GT.0 ) + + INFO = INFO + K + IF( INFO.GT.0 ) + + RETURN + CALL ZTRMM( 'L', 'L', 'N', DIAG, K, K, CONE, A( K*K ), K, + + A( 0 ), K ) + END IF + END IF + END IF +* + RETURN +* +* End of ZTFTRI +* + END diff --git a/SRC/ztfttp.f b/SRC/ztfttp.f new file mode 100644 index 00000000..bafd0abf --- /dev/null +++ b/SRC/ztfttp.f @@ -0,0 +1,478 @@ + SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + COMPLEX*16 AP( 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* ZTFTTP copies a triangular matrix A from rectangular full packed +* format (TF) to standard packed format (TP). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'C': ARF is in Conjugate-transpose format; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. Intrinsic Functions .. +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTFTTP', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + AP( 0 ) = ARF( 0 ) + ELSE + AP( 0 ) = DCONJG( ARF( 0 ) ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + AP( IJP ) = ARF( IJ ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + AP( IJP ) = DCONJG( ARF( IJ ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZTFTTP +* + END diff --git a/SRC/ztfttr.f b/SRC/ztfttr.f new file mode 100644 index 00000000..384c41d1 --- /dev/null +++ b/SRC/ztfttr.f @@ -0,0 +1,470 @@ + SUBROUTINE ZTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* ZTFTTR copies a triangular matrix A from rectangular full packed +* format (TF) to standard full format (TR). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF is in Normal format; +* = 'C': ARF is in Conjugate-transpose format; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* ARF (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* A (output) COMPLEX*16 array, dimension ( LDA, N ) +* On exit, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT, NX2, NP1X2 + INTEGER I, J, L, IJ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTFTTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + A( 0, 0 ) = ARF( 0 ) + ELSE + A( 0, 0 ) = DCONJG( ARF( 0 ) ) + END IF + END IF + RETURN + END IF +* +* Size of array ARF(1:2,0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + A( N2+J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + A( J-N1, L ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + A( J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + A( I, N1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + A( J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda = n2 +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + A( J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + A( N2+J, L ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + A( K+J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + A( J-K, L ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : +* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k +* + IJ = 0 + J = K + DO I = K, N - 1 + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + A( J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + A( I, K+1+J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + A( J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) +* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + A( J, I ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + A( K+1+J, L ) = DCONJG( ARF( IJ ) ) + IJ = IJ + 1 + END DO + END DO +* +* Note that here J = K-1 +* + DO I = 0, J + A( I, J ) = ARF( IJ ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZTFTTR +* + END diff --git a/SRC/ztgevc.f b/SRC/ztgevc.f index b8da962d..e0b67a8a 100644 --- a/SRC/ztgevc.f +++ b/SRC/ztgevc.f @@ -1,7 +1,7 @@ SUBROUTINE ZTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, $ LDVL, VR, LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztgex2.f b/SRC/ztgex2.f index a0c42aad..a0db2b33 100644 --- a/SRC/ztgex2.f +++ b/SRC/ztgex2.f @@ -1,7 +1,7 @@ SUBROUTINE ZTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, J1, INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztgexc.f b/SRC/ztgexc.f index 0f57939c..7cd2a4be 100644 --- a/SRC/ztgexc.f +++ b/SRC/ztgexc.f @@ -1,7 +1,7 @@ SUBROUTINE ZTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, $ LDZ, IFST, ILST, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztgsen.f b/SRC/ztgsen.f index 4c5acaff..b9bcaf22 100644 --- a/SRC/ztgsen.f +++ b/SRC/ztgsen.f @@ -2,7 +2,7 @@ $ ALPHA, BETA, Q, LDQ, Z, LDZ, M, PL, PR, DIF, $ WORK, LWORK, IWORK, LIWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/ztgsja.f b/SRC/ztgsja.f index 05653757..895aaaf7 100644 --- a/SRC/ztgsja.f +++ b/SRC/ztgsja.f @@ -2,7 +2,7 @@ $ LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, $ Q, LDQ, WORK, NCYCLE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztgsna.f b/SRC/ztgsna.f index 3d6cd826..af7399da 100644 --- a/SRC/ztgsna.f +++ b/SRC/ztgsna.f @@ -2,7 +2,7 @@ $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztgsy2.f b/SRC/ztgsy2.f index 82ec5eb1..a84b5fbd 100644 --- a/SRC/ztgsy2.f +++ b/SRC/ztgsy2.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, $ INFO ) * -* -- LAPACK auxiliary routine (version 3.1) -- +* -- LAPACK auxiliary routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztgsyl.f b/SRC/ztgsyl.f index 7be8e987..e7593c0a 100644 --- a/SRC/ztgsyl.f +++ b/SRC/ztgsyl.f @@ -2,7 +2,7 @@ $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, $ IWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/ztpcon.f b/SRC/ztpcon.f index 63d1f88f..cfe1ef39 100644 --- a/SRC/ztpcon.f +++ b/SRC/ztpcon.f @@ -1,7 +1,7 @@ SUBROUTINE ZTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztprfs.f b/SRC/ztprfs.f index 081b452c..039c9910 100644 --- a/SRC/ztprfs.f +++ b/SRC/ztprfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, $ FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztptri.f b/SRC/ztptri.f index 8fa22865..64cef8e2 100644 --- a/SRC/ztptri.f +++ b/SRC/ztptri.f @@ -1,6 +1,6 @@ SUBROUTINE ZTPTRI( UPLO, DIAG, N, AP, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztptrs.f b/SRC/ztptrs.f index c50503e3..3d04f0aa 100644 --- a/SRC/ztptrs.f +++ b/SRC/ztptrs.f @@ -1,6 +1,6 @@ SUBROUTINE ZTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztpttf.f b/SRC/ztpttf.f new file mode 100644 index 00000000..9e49eae6 --- /dev/null +++ b/SRC/ztpttf.f @@ -0,0 +1,476 @@ + SUBROUTINE ZTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + COMPLEX*16 AP( 0: * ), ARF( 0: * ) +* +* Purpose +* ======= +* +* ZTPTTF copies a triangular matrix A from standard packed format (TP) +* to rectangular full packed format (TF). +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal format is wanted; +* = 'C': ARF in Conjugate-transpose format is wanted. +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes: +* ====== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = 'N'. RFP holds AP as follows: +* For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = 'N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER N1, N2, K, NT + INTEGER I, J, IJ + INTEGER IJP, JP, LDA, JS +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTPTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + + RETURN +* + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = AP( 0 ) + ELSE + ARF( 0 ) = DCONJG( AP( 0 ) ) + END IF + RETURN + END IF +* +* Size of array ARF(0:NT-1) +* + NT = N*( N+1 ) / 2 +* +* Set N1 and N2 depending on LOWER +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE. +* If N is even, set K = N/2 and NISODD = .FALSE. +* +* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) +* where noe = 0 if n is even, noe = 1 if n is odd +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + LDA = N + 1 + ELSE + NISODD = .TRUE. + LDA = N + END IF +* +* ARF^C has lda rows and n+1-noe cols +* + IF( .NOT.NORMALTRANSR ) + + LDA = ( N+1 ) / 2 +* +* start execution: there are eight cases +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n +* + IJP = 0 + JP = 0 + DO J = 0, N2 + DO I = J, N - 1 + IJ = I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, N2 - 1 + DO J = 1 + I, N2 + IJ = I + J*LDA + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0) +* + IJP = 0 + DO J = 0, N1 - 1 + IJ = N2 + J + DO I = 0, J + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = N1, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 +* + IJP = 0 + DO I = 0, N2 + DO IJ = I*( LDA+1 ), N*LDA - 1, LDA + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO + JS = 1 + DO J = 0, N2 - 1 + DO IJ = JS, JS + N2 - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 +* + IJP = 0 + JS = N2*LDA + DO J = 0, N1 - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, N1 + DO IJ = I, I + ( N1+I )*LDA, LDA + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1) +* + IJP = 0 + JP = 0 + DO J = 0, K - 1 + DO I = J, N - 1 + IJ = 1 + I + JP + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JP = JP + LDA + END DO + DO I = 0, K - 1 + DO J = I, K - 1 + IJ = I + J*LDA + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0) +* + IJP = 0 + DO J = 0, K - 1 + IJ = K + 1 + J + DO I = 0, J + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + IJ = IJ + LDA + END DO + END DO + JS = 0 + DO J = K, N - 1 + IJ = JS + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) +* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k +* + IJP = 0 + DO I = 0, K - 1 + DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO + JS = 0 + DO J = 0, K - 1 + DO IJ = JS, JS + K - J - 1 + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + 1 + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper) +* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) +* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k +* + IJP = 0 + JS = ( K+1 )*LDA + DO J = 0, K - 1 + DO IJ = JS, JS + J + ARF( IJ ) = AP( IJP ) + IJP = IJP + 1 + END DO + JS = JS + LDA + END DO + DO I = 0, K - 1 + DO IJ = I, I + ( K+I )*LDA, LDA + ARF( IJ ) = DCONJG( AP( IJP ) ) + IJP = IJP + 1 + END DO + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZTPTTF +* + END diff --git a/SRC/ztpttr.f b/SRC/ztpttr.f new file mode 100644 index 00000000..2325e700 --- /dev/null +++ b/SRC/ztpttr.f @@ -0,0 +1,114 @@ + SUBROUTINE ZTPTTR( UPLO, N, AP, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* ZTPTTR copies a triangular matrix A from standard packed format (TP) +* to standard full format (TR). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular. +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On entry, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* A (output) COMPLEX*16 array, dimension ( LDA, N ) +* On exit, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTPTTR', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + A( I, J ) = AP( K ) + END DO + END DO + END IF +* +* + RETURN +* +* End of ZTPTTR +* + END diff --git a/SRC/ztrcon.f b/SRC/ztrcon.f index 755072e6..337bf833 100644 --- a/SRC/ztrcon.f +++ b/SRC/ztrcon.f @@ -1,7 +1,7 @@ SUBROUTINE ZTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, $ RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrevc.f b/SRC/ztrevc.f index 21142f42..b59d7a42 100644 --- a/SRC/ztrevc.f +++ b/SRC/ztrevc.f @@ -1,7 +1,7 @@ SUBROUTINE ZTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, $ LDVR, MM, M, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrexc.f b/SRC/ztrexc.f index 69313696..14c5f6b8 100644 --- a/SRC/ztrexc.f +++ b/SRC/ztrexc.f @@ -1,6 +1,6 @@ SUBROUTINE ZTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrrfs.f b/SRC/ztrrfs.f index 364f5113..11833234 100644 --- a/SRC/ztrrfs.f +++ b/SRC/ztrrfs.f @@ -1,7 +1,7 @@ SUBROUTINE ZTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, $ LDX, FERR, BERR, WORK, RWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrsen.f b/SRC/ztrsen.f index a07a22f6..e5779a72 100644 --- a/SRC/ztrsen.f +++ b/SRC/ztrsen.f @@ -1,7 +1,7 @@ SUBROUTINE ZTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, W, M, S, $ SEP, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrsna.f b/SRC/ztrsna.f index 0f940f6d..5d048951 100644 --- a/SRC/ztrsna.f +++ b/SRC/ztrsna.f @@ -2,7 +2,7 @@ $ LDVR, S, SEP, MM, M, WORK, LDWORK, RWORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrsyl.f b/SRC/ztrsyl.f index d2e0ecc7..ed0a2c85 100644 --- a/SRC/ztrsyl.f +++ b/SRC/ztrsyl.f @@ -1,7 +1,7 @@ SUBROUTINE ZTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, $ LDC, SCALE, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrti2.f b/SRC/ztrti2.f index 73c7bbc3..1b860528 100644 --- a/SRC/ztrti2.f +++ b/SRC/ztrti2.f @@ -1,6 +1,6 @@ SUBROUTINE ZTRTI2( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrtri.f b/SRC/ztrtri.f index 7caa9771..b8d12246 100644 --- a/SRC/ztrtri.f +++ b/SRC/ztrtri.f @@ -1,6 +1,6 @@ SUBROUTINE ZTRTRI( UPLO, DIAG, N, A, LDA, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrtrs.f b/SRC/ztrtrs.f index b42d5a58..8ff54ff5 100644 --- a/SRC/ztrtrs.f +++ b/SRC/ztrtrs.f @@ -1,7 +1,7 @@ SUBROUTINE ZTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztrttf.f b/SRC/ztrttf.f new file mode 100644 index 00000000..61c6a82c --- /dev/null +++ b/SRC/ztrttf.f @@ -0,0 +1,469 @@ + SUBROUTINE ZTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- November 2008 -- +* +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER TRANSR, UPLO + INTEGER INFO, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( 0: LDA-1, 0: * ), ARF( 0: * ) +* .. +* +* Purpose +* ======= +* +* ZTRTTF copies a triangular matrix A from standard full format (TR) +* to rectangular full packed format (TF) . +* +* Arguments +* ========= +* +* TRANSR (input) CHARACTER +* = 'N': ARF in Normal mode is wanted; +* = 'C': ARF in Conjugate Transpose mode is wanted; +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension ( LDA, N ) +* On entry, the triangular matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of the array A contains +* the upper triangular matrix, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of the array A contains +* the lower triangular matrix, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the matrix A. LDA >= max(1,N). +* +* ARF (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A stored in +* RFP format. For a further discussion see Notes below. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Notes +* ===== +* +* We first consider Standard Packed Format when N is even. +* We give an example where N = 6. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 05 00 +* 11 12 13 14 15 10 11 +* 22 23 24 25 20 21 22 +* 33 34 35 30 31 32 33 +* 44 45 40 41 42 43 44 +* 55 50 51 52 53 54 55 +* +* +* Let TRANSR = `N'. RFP holds AP as follows: +* For UPLO = `U' the upper trapezoid A(0:5,0:2) consists of the last +* three columns of AP upper. The lower triangle A(4:6,0:2) consists of +* conjugate-transpose of the first three columns of AP upper. +* For UPLO = `L' the lower trapezoid A(1:6,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:2,0:2) consists of +* conjugate-transpose of the last three columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N even and TRANSR = `N'. +* +* RFP A RFP A +* +* -- -- -- +* 03 04 05 33 43 53 +* -- -- +* 13 14 15 00 44 54 +* -- +* 23 24 25 10 11 55 +* +* 33 34 35 20 21 22 +* -- +* 00 44 45 30 31 32 +* -- -- +* 01 11 55 40 41 42 +* -- -- -- +* 02 12 22 50 51 52 +* +* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- -- +* 03 13 23 33 00 01 02 33 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 11 12 43 44 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- -- +* 05 15 25 35 45 55 22 53 54 55 22 32 42 52 +* +* +* We next consider Standard Packed Format when N is odd. +* We give an example where N = 5. +* +* AP is Upper AP is Lower +* +* 00 01 02 03 04 00 +* 11 12 13 14 10 11 +* 22 23 24 20 21 22 +* 33 34 30 31 32 33 +* 44 40 41 42 43 44 +* +* +* Let TRANSR = `N'. RFP holds AP as follows: +* For UPLO = `U' the upper trapezoid A(0:4,0:2) consists of the last +* three columns of AP upper. The lower triangle A(3:4,0:1) consists of +* conjugate-transpose of the first two columns of AP upper. +* For UPLO = `L' the lower trapezoid A(0:4,0:2) consists of the first +* three columns of AP lower. The upper triangle A(0:1,1:2) consists of +* conjugate-transpose of the last two columns of AP lower. +* To denote conjugate we place -- above the element. This covers the +* case N odd and TRANSR = `N'. +* +* RFP A RFP A +* +* -- -- +* 02 03 04 00 33 43 +* -- +* 12 13 14 10 11 44 +* +* 22 23 24 20 21 22 +* -- +* 00 33 34 30 31 32 +* -- -- +* 01 11 44 40 41 42 +* +* Now let TRANSR = `C'. RFP A in both UPLO cases is just the conjugate- +* transpose of RFP A above. One therefore gets: +* +* +* RFP A RFP A +* +* -- -- -- -- -- -- -- -- -- +* 02 12 22 00 01 00 10 20 30 40 50 +* -- -- -- -- -- -- -- -- -- +* 03 13 23 33 11 33 11 21 31 41 51 +* -- -- -- -- -- -- -- -- -- +* 04 14 24 34 44 43 44 22 32 42 52 +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER, NISODD, NORMALTRANSR + INTEGER I, IJ, J, K, L, N1, N2, NT, NX2, NP1X2 +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MOD +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NORMALTRANSR = LSAME( TRANSR, 'N' ) + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN + INFO = -1 + ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZTRTTF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) THEN + IF( N.EQ.1 ) THEN + IF( NORMALTRANSR ) THEN + ARF( 0 ) = A( 0, 0 ) + ELSE + ARF( 0 ) = DCONJG( A( 0, 0 ) ) + END IF + END IF + RETURN + END IF +* +* Size of array ARF(1:2,0:nt-1) +* + NT = N*( N+1 ) / 2 +* +* set N1 and N2 depending on LOWER: for N even N1=N2=K +* + IF( LOWER ) THEN + N2 = N / 2 + N1 = N - N2 + ELSE + N1 = N / 2 + N2 = N - N1 + END IF +* +* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. +* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is +* N--by--(N+1)/2. +* + IF( MOD( N, 2 ).EQ.0 ) THEN + K = N / 2 + NISODD = .FALSE. + IF( .NOT.LOWER ) + + NP1X2 = N + N + 2 + ELSE + NISODD = .TRUE. + IF( .NOT.LOWER ) + + NX2 = N + N + END IF +* + IF( NISODD ) THEN +* +* N is odd +* + IF( NORMALTRANSR ) THEN +* +* N is odd and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) +* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) +* T1 -> a(0), T2 -> a(n), S -> a(n1); lda=n +* + IJ = 0 + DO J = 0, N2 + DO I = N1, N2 + J + ARF( IJ ) = DCONJG( A( N2+J, I ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) +* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) +* T1 -> a(n2), T2 -> a(n1), S -> a(0); lda=n +* + IJ = NT - N + DO J = N - 1, N1, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - N1, N1 - 1 + ARF( IJ ) = DCONJG( A( J-N1, L ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NX2 + END DO +* + END IF +* + ELSE +* +* N is odd and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is odd +* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) +* T1 -> A(0+0) , T2 -> A(1+0) , S -> A(0+n1*n1); lda=n1 +* + IJ = 0 + DO J = 0, N2 - 1 + DO I = 0, J + ARF( IJ ) = DCONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + DO I = N1 + J, N - 1 + ARF( IJ ) = A( I, N1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = N2, N - 1 + DO I = 0, N1 - 1 + ARF( IJ ) = DCONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is odd +* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) +* T1 -> A(n2*n2), T2 -> A(n1*n2), S -> A(0); lda=n2 +* + IJ = 0 + DO J = 0, N1 + DO I = N1, N - 1 + ARF( IJ ) = DCONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, N1 - 1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = N2 + J, N - 1 + ARF( IJ ) = DCONJG( A( N2+J, L ) ) + IJ = IJ + 1 + END DO + END DO +* + END IF +* + END IF +* + ELSE +* +* N is even +* + IF( NORMALTRANSR ) THEN +* +* N is even and TRANSR = 'N' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) +* T1 -> a(1), T2 -> a(0), S -> a(k+1); lda=n+1 +* + IJ = 0 + DO J = 0, K - 1 + DO I = K, K + J + ARF( IJ ) = DCONJG( A( K+J, I ) ) + IJ = IJ + 1 + END DO + DO I = J, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) +* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) +* T1 -> a(k+1), T2 -> a(k), S -> a(0); lda=n+1 +* + IJ = NT - N - 1 + DO J = N - 1, K, -1 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = J - K, K - 1 + ARF( IJ ) = DCONJG( A( J-K, L ) ) + IJ = IJ + 1 + END DO + IJ = IJ - NP1X2 + END DO +* + END IF +* + ELSE +* +* N is even and TRANSR = 'C' +* + IF( LOWER ) THEN +* +* SRPA for LOWER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,1) , T2 -> A(0,0) , S -> A(0,k+1) : +* T1 -> A(0+k) , T2 -> A(0+0) , S -> A(0+k*(k+1)); lda=k +* + IJ = 0 + J = K + DO I = K, N - 1 + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = DCONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + DO I = K + 1 + J, N - 1 + ARF( IJ ) = A( I, K+1+J ) + IJ = IJ + 1 + END DO + END DO + DO J = K - 1, N - 1 + DO I = 0, K - 1 + ARF( IJ ) = DCONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO +* + ELSE +* +* SRPA for UPPER, TRANSPOSE and N is even (see paper, A=B) +* T1 -> A(0,k+1) , T2 -> A(0,k) , S -> A(0,0) +* T1 -> A(0+k*(k+1)) , T2 -> A(0+k*k) , S -> A(0+0)); lda=k +* + IJ = 0 + DO J = 0, K + DO I = K, N - 1 + ARF( IJ ) = DCONJG( A( J, I ) ) + IJ = IJ + 1 + END DO + END DO + DO J = 0, K - 2 + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO + DO L = K + 1 + J, N - 1 + ARF( IJ ) = DCONJG( A( K+1+J, L ) ) + IJ = IJ + 1 + END DO + END DO +* +* Note that here J = K-1 +* + DO I = 0, J + ARF( IJ ) = A( I, J ) + IJ = IJ + 1 + END DO +* + END IF +* + END IF +* + END IF +* + RETURN +* +* End of ZTRTTF +* + END diff --git a/SRC/ztrttp.f b/SRC/ztrttp.f new file mode 100644 index 00000000..c89b3fdf --- /dev/null +++ b/SRC/ztrttp.f @@ -0,0 +1,115 @@ + SUBROUTINE ZTRTTP( UPLO, N, A, LDA, AP, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* +* -- Contributed by Fred Gustavson of the IBM Watson Research Center -- +* -- and Julien Langou of the Univ. of Colorado Denver -- +* -- November 2008 -- +* +* -- 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, N, LDA +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AP( * ) +* .. +* +* Purpose +* ======= +* +* ZTRTTP copies a triangular matrix A from full format (TR) to standard +* packed format (TP). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER +* = 'U': A is upper triangular; +* = 'L': A is lower triangular. +* +* N (input) INTEGER +* The order of the matrices AP and A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* On entry, the triangular matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* AP (output) COMPLEX*16 array, dimension ( N*(N+1)/2 ), +* On exit, the upper or lower triangular matrix A, packed +* columnwise in a linear array. The j-th column of A is stored +* in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. +* .. +* .. Local Scalars .. + LOGICAL LOWER + INTEGER I, J, K +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + LOWER = LSAME( UPLO, 'L' ) + IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) 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( 'ZTRTTP', -INFO ) + RETURN + END IF +* + IF( LOWER ) THEN + K = 0 + DO J = 1, N + DO I = J, N + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + ELSE + K = 0 + DO J = 1, N + DO I = 1, J + K = K + 1 + AP( K ) = A( I, J ) + END DO + END DO + END IF +* +* + RETURN +* +* End of ZTRTTP +* + END diff --git a/SRC/ztzrqf.f b/SRC/ztzrqf.f index 9217b441..4afb118d 100644 --- a/SRC/ztzrqf.f +++ b/SRC/ztzrqf.f @@ -1,6 +1,6 @@ SUBROUTINE ZTZRQF( M, N, A, LDA, TAU, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/ztzrzf.f b/SRC/ztzrzf.f index 5c9c6543..7d9e5981 100644 --- a/SRC/ztzrzf.f +++ b/SRC/ztzrzf.f @@ -1,6 +1,6 @@ SUBROUTINE ZTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zung2l.f b/SRC/zung2l.f index 29178b90..73c940ef 100644 --- a/SRC/zung2l.f +++ b/SRC/zung2l.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zung2r.f b/SRC/zung2r.f index cd89f26e..b4416bc3 100644 --- a/SRC/zung2r.f +++ b/SRC/zung2r.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungbr.f b/SRC/zungbr.f index 94f74820..7ee2fcb8 100644 --- a/SRC/zungbr.f +++ b/SRC/zungbr.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunghr.f b/SRC/zunghr.f index fcf32abf..a42c069b 100644 --- a/SRC/zunghr.f +++ b/SRC/zunghr.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungl2.f b/SRC/zungl2.f index 502411b4..f03a3b30 100644 --- a/SRC/zungl2.f +++ b/SRC/zungl2.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunglq.f b/SRC/zunglq.f index ab4a018f..d3e96cb1 100644 --- a/SRC/zunglq.f +++ b/SRC/zunglq.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungql.f b/SRC/zungql.f index 4232abea..1b93aa07 100644 --- a/SRC/zungql.f +++ b/SRC/zungql.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungqr.f b/SRC/zungqr.f index bf5c6997..954289a0 100644 --- a/SRC/zungqr.f +++ b/SRC/zungqr.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungr2.f b/SRC/zungr2.f index 70f52314..5118fd8e 100644 --- a/SRC/zungr2.f +++ b/SRC/zungr2.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungrq.f b/SRC/zungrq.f index dc34b253..19176c74 100644 --- a/SRC/zungrq.f +++ b/SRC/zungrq.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zungtr.f b/SRC/zungtr.f index 5de7c109..679bd0ce 100644 --- a/SRC/zungtr.f +++ b/SRC/zungtr.f @@ -1,6 +1,6 @@ SUBROUTINE ZUNGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunm2l.f b/SRC/zunm2l.f index 287f6207..afcc8a7d 100644 --- a/SRC/zunm2l.f +++ b/SRC/zunm2l.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunm2r.f b/SRC/zunm2r.f index 7d4c067a..5614c4d5 100644 --- a/SRC/zunm2r.f +++ b/SRC/zunm2r.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmbr.f b/SRC/zunmbr.f index b32ce338..58866963 100644 --- a/SRC/zunmbr.f +++ b/SRC/zunmbr.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmhr.f b/SRC/zunmhr.f index 4424540d..34e509d1 100644 --- a/SRC/zunmhr.f +++ b/SRC/zunmhr.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C, $ LDC, WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunml2.f b/SRC/zunml2.f index cced4a77..e46edc22 100644 --- a/SRC/zunml2.f +++ b/SRC/zunml2.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmlq.f b/SRC/zunmlq.f index b1708757..946abdaa 100644 --- a/SRC/zunmlq.f +++ b/SRC/zunmlq.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmql.f b/SRC/zunmql.f index 3a9edb45..05885b95 100644 --- a/SRC/zunmql.f +++ b/SRC/zunmql.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmqr.f b/SRC/zunmqr.f index f9b1e98f..cba955e0 100644 --- a/SRC/zunmqr.f +++ b/SRC/zunmqr.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmr2.f b/SRC/zunmr2.f index c476d19f..0126d4f5 100644 --- a/SRC/zunmr2.f +++ b/SRC/zunmr2.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmr3.f b/SRC/zunmr3.f index 111c1c95..8c329e8c 100644 --- a/SRC/zunmr3.f +++ b/SRC/zunmr3.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmrq.f b/SRC/zunmrq.f index 99a3ea21..64f3cc84 100644 --- a/SRC/zunmrq.f +++ b/SRC/zunmrq.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zunmrz.f b/SRC/zunmrz.f index dcce6869..5be51837 100644 --- a/SRC/zunmrz.f +++ b/SRC/zunmrz.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * January 2007 * diff --git a/SRC/zunmtr.f b/SRC/zunmtr.f index a3b2b12e..28c6b311 100644 --- a/SRC/zunmtr.f +++ b/SRC/zunmtr.f @@ -1,7 +1,7 @@ SUBROUTINE ZUNMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, $ WORK, LWORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zupgtr.f b/SRC/zupgtr.f index 1c8039d9..fb0d0959 100644 --- a/SRC/zupgtr.f +++ b/SRC/zupgtr.f @@ -1,6 +1,6 @@ SUBROUTINE ZUPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * diff --git a/SRC/zupmtr.f b/SRC/zupmtr.f index 8d539609..c5935b77 100644 --- a/SRC/zupmtr.f +++ b/SRC/zupmtr.f @@ -1,7 +1,7 @@ SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, $ INFO ) * -* -- LAPACK routine (version 3.1) -- +* -- LAPACK routine (version 3.2) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. * November 2006 * |