diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake index a8d1c601c8..48b33fe85d 100644 --- a/cmake/lapack.cmake +++ b/cmake/lapack.cmake @@ -71,7 +71,7 @@ set(SLASRC slaqr0.f slaqr1.f slaqr2.f slaqr3.f slaqr4.f slaqr5.f slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f slarf.f slarfb.f slarfb_gett.f slarfg.f slarfgp.f slarft.f slarfx.f slarfy.f slargv.f - slarrv.f slartv.f + slarf1f.f slarf1l.f slarrv.f slartv.f slarz.f slarzb.f slarzt.f slasy2.f slasyf.f slasyf_rook.f slasyf_rk.f slasyf_aa.f slatbs.f slatdf.f slatps.f slatrd.f slatrs.f slatrz.f @@ -178,6 +178,7 @@ set(CLASRC claqz0.f claqz1.f claqz2.f claqz3.f claqsp.f claqsy.f clar1v.f clar2v.f ilaclr.f ilaclc.f clarf.f clarfb.f clarfb_gett.f clarfg.f clarfgp.f clarft.f + clarf1f.f clarf1l.f clarfx.f clarfy.f clargv.f clarnv.f clarrv.f clartg.f90 clartv.f clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f90 clasyf.f clasyf_rook.f clasyf_rk.f clasyf_aa.f @@ -262,7 +263,7 @@ set(DLASRC dlaqr0.f dlaqr1.f dlaqr2.f dlaqr3.f dlaqr4.f dlaqr5.f dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f dlarf.f dlarfb.f dlarfb_gett.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlarfy.f - dlargv.f dlarrv.f dlartv.f + dlarf1f.f dlarf1l.f dlargv.f dlarrv.f dlartv.f dlarz.f dlarzb.f dlarzt.f dlasy2.f dlasyf.f dlasyf_rook.f dlasyf_rk.f dlasyf_aa.f dlatbs.f dlatdf.f dlatps.f dlatrd.f dlatrs.f dlatrz.f @@ -371,7 +372,7 @@ set(ZLASRC zlaqr0.f zlaqr1.f zlaqr2.f zlaqr3.f zlaqr4.f zlaqr5.f zlaqsp.f zlaqsy.f zlar1v.f zlar2v.f ilazlr.f ilazlc.f zlarcm.f zlarf.f zlarfb.f zlarfb_gett.f - zlarfg.f zlarfgp.f zlarft.f + zlarfg.f zlarfgp.f zlarft.f zlarf1f.f zlarf1l.f zlarfx.f zlarfy.f zlargv.f zlarnv.f zlarrv.f zlartg.f90 zlartv.f zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f zlassq.f90 zlasyf.f zlasyf_rook.f zlasyf_rk.f zlasyf_aa.f diff --git a/lapack-netlib/Makefile b/lapack-netlib/Makefile index d5e75b69e6..b564b72b29 100644 --- a/lapack-netlib/Makefile +++ b/lapack-netlib/Makefile @@ -1,182 +1,699 @@ +####################################################################### +# This is the makefile to create a library for LAPACK. +# The files are organized as follows: # -# Top Level Makefile for LAPACK -# Version 3.4.1 -# April 2012 +# ALLAUX -- Auxiliary routines called from all precisions +# SCLAUX -- Auxiliary routines called from single precision +# DZLAUX -- Auxiliary routines called from double precision # +# DSLASRC -- Double-single mixed precision real routines called from +# single, single-extra and double precision real LAPACK +# routines (i.e. from SLASRC, SXLASRC, DLASRC). +# ZCLASRC -- Double-single mixed precision complex routines called from +# single, single-extra and double precision complex LAPACK +# routines (i.e. from CLASRC, CXLASRC, ZLASRC). +# +# 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. +# +# DEPRECATED -- Deprecated routines in all precisions +# +# 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 +# followed by one or more of the precisions desired. Some examples: +# make single +# make single complex +# make single double complex complex16 +# Alternatively, the command +# make +# without any arguments creates a library of all four precisions. +# The library is called +# lapack.a +# and is created at the next higher directory level. +# +# To remove the object files after the library is created, enter +# make cleanobj +# On some systems, you can force the source files to be recompiled by +# entering (for example) +# make single FRC=FRC +# +# ***Note*** +# The functions lsame, second, dsecnd, slamch, and dlamch may have +# to be installed before compiling the library. Refer to the +# installation guide, LAPACK Working Note 41, for instructions. +# +####################################################################### -TOPSRCDIR = . +TOPSRCDIR = .. include $(TOPSRCDIR)/make.inc +ifneq ($(C_LAPACK), 1) +ALLMOD = la_xisnan.mod la_constants.mod + +.SUFFIXES: +.SUFFIXES: .f .F .f90 .F90 .o .mod +%.o: %.f + $(FC) $(FFLAGS) -c -o $@ $< +%.o: %.F $(ALLMOD) + $(FC) $(FFLAGS) -c -o $@ $< +%.o: %.f90 $(ALLMOD) + $(FC) $(FFLAGS) -c -o $@ $< +%.o: %.F90 $(ALLMOD) + $(FC) $(FFLAGS) -c -o $@ $< +.o.mod: + @true + +else +.SUFFIXES: .c .o +.c.o: + $(CC) $(CFLAGS) -c -o $@ $< +endif + +ALLAUX_O = ilaenv.o ilaenv2stage.o ieeeck.o lsamen.o xerbla.o xerbla_array.o \ + iparmq.o iparam2stage.o \ + ilaprec.o ilatrans.o ilauplo.o iladiag.o chla_transtype.o la_xisnan.o \ + ../INSTALL/ilaver.o ../INSTALL/lsame.o ../INSTALL/slamch.o + +ifneq "$(or $(BUILD_SINGLE),$(BUILD_COMPLEX))" "" +SCLAUX_O = la_constants.o \ + sbdsvdx.o sstevx.o sstein.o \ + sbdsdc.o \ + sbdsqr.o sdisna.o slabad.o slacpy.o sladiv.o slae2.o slaebz.o \ + slaed0.o slaed1.o slaed2.o slaed3.o slaed4.o slaed5.o slaed6.o \ + slaed7.o slaed8.o slaed9.o slaeda.o slaev2.o slagtf.o \ + slagts.o slamrg.o slanst.o \ + slapy2.o slapy3.o slarnv.o \ + slarra.o slarrb.o slarrc.o slarrd.o slarre.o slarrf.o slarrj.o \ + slarrk.o slarrr.o slaneg.o slarmm.o \ + 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 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 \ + slartgp.o slartgs.o scombssq.o ../INSTALL/sroundup_lwork.o \ + ../INSTALL/second_$(TIMER).o +endif + +ifneq "$(or $(BUILD_DOUBLE),$(BUILD_COMPLEX16))" "" +DZLAUX_O = la_constants.o\ + dcombssq.o \ + dbdsvdx.o dstevx.o dstein.o \ + dbdsdc.o \ + dbdsqr.o ddisna.o dlabad.o dlacpy.o dladiv.o dlae2.o dlaebz.o \ + dlaed0.o dlaed1.o dlaed2.o dlaed3.o dlaed4.o dlaed5.o dlaed6.o \ + dlaed7.o dlaed8.o dlaed9.o dlaeda.o dlaev2.o dlagtf.o \ + dlagts.o dlamrg.o dlanst.o \ + dlapy2.o dlapy3.o dlarnv.o \ + dlarra.o dlarrb.o dlarrc.o dlarrd.o dlarre.o dlarrf.o dlarrj.o \ + dlarrk.o dlarrr.o dlaneg.o dlarmm.o \ + 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 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 \ + dlartgp.o dlartgs.o ../INSTALL/droundup_lwork.o \ + ../INSTALL/dlamch.o ../INSTALL/dsecnd_$(TIMER).o +endif + +#ifeq ($(BUILD_SINGLE),1) +ifdef BUILD_SINGLE +SLASRC_O = \ + spotrf2.o sgetrf2.o \ + sgbbrd.o sgbcon.o sgbequ.o sgbrfs.o sgbsv.o \ + sgbsvx.o sgbtf2.o sgbtrf.o sgbtrs.o sgebak.o sgebal.o sgebd2.o \ + sgebrd.o sgecon.o sgeequ.o sgees.o sgeesx.o sgeev.o sgeevx.o \ + sgehd2.o sgehrd.o sgelq2.o sgelqf.o \ + sgels.o sgelsd.o sgelss.o sgelsy.o sgeql2.o sgeqlf.o \ + sgeqp3.o sgeqp3rk.o sgeqr2.o sgeqr2p.o sgeqrf.o sgeqrfp.o sgerfs.o \ + sgerq2.o sgerqf.o sgesc2.o sgesdd.o sgesv.o sgesvd.o sgesvdx.o sgesvx.o \ + sgetc2.o sgetf2.o sgetri.o \ + sggbak.o sggbal.o sgges.o sgges3.o sggesx.o \ + sggev.o sggev3.o sggevx.o \ + sggglm.o sgghrd.o sgghd3.o sgglse.o sggqrf.o \ + sggrqf.o sggsvd3.o sggsvp3.o sgtcon.o sgtrfs.o sgtsv.o \ + sgtsvx.o sgttrf.o sgttrs.o sgtts2.o shgeqz.o \ + slaqz0.o slaqz1.o slaqz2.o slaqz3.o slaqz4.o \ + shsein.o shseqr.o slabrd.o slacon.o slacn2.o \ + slaein.o slaexc.o slag2.o slags2.o slagtm.o slagv2.o slahqr.o \ + slahr2.o slaic1.o slaln2.o slals0.o slalsa.o slalsd.o \ + slangb.o slange.o slangt.o slanhs.o slansb.o slansp.o \ + slansy.o slantb.o slantp.o slantr.o slanv2.o \ + slapll.o slapmt.o \ + slaqgb.o slaqge.o slaqp2.o slaqp2rk.o slaqp3rk.o slaqps.o slaqsb.o slaqsp.o slaqsy.o \ + slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ + slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ + slarf.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o slargv.o \ + slarrv.o slartv.o \ + slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ + slasyf_rk.o \ + slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o \ + slauu2.o slauum.o sopgtr.o sopmtr.o sorg2l.o sorg2r.o \ + sorgbr.o sorghr.o sorgl2.o sorglq.o sorgql.o sorgqr.o sorgr2.o \ + sorgrq.o sorgtr.o sorgtsqr.o sorgtsqr_row.o sorm2l.o sorm2r.o sorm22.o \ + sormbr.o sormhr.o sorml2.o sormlq.o sormql.o sormqr.o sormr2.o \ + 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 spotri.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 \ + ssbtrd.o sspcon.o sspev.o sspevd.o sspevx.o sspgst.o \ + sspgv.o sspgvd.o sspgvx.o ssprfs.o sspsv.o sspsvx.o ssptrd.o \ + ssptrf.o ssptri.o ssptrs.o sstegr.o sstev.o sstevd.o sstevr.o \ + ssycon.o ssyev.o ssyevd.o ssyevr.o ssyevx.o ssygs2.o \ + ssygst.o ssygv.o ssygvd.o ssygvx.o ssyrfs.o ssysv.o ssysvx.o \ + ssytd2.o ssytf2.o ssytrd.o ssytrf.o ssytri.o ssytri2.o ssytri2x.o \ + ssyswapr.o ssytrs.o ssytrs2.o \ + ssyconv.o ssyconvf.o ssyconvf_rook.o \ + ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \ + ssytri_rook.o ssycon_rook.o ssysv_rook.o \ + ssytf2_rk.o ssytrf_rk.o ssytrs_3.o \ + ssytri_3.o ssytri_3x.o ssycon_3.o ssysv_rk.o \ + slasyf_aa.o ssysv_aa.o ssytrf_aa.o ssytrs_aa.o \ + ssysv_aa_2stage.o ssytrf_aa_2stage.o ssytrs_aa_2stage.o \ + stbcon.o \ + stbrfs.o stbtrs.o stgevc.o stgex2.o stgexc.o stgsen.o \ + stgsja.o stgsna.o stgsy2.o stgsyl.o stpcon.o stprfs.o stptri.o \ + stptrs.o \ + strcon.o strevc.o strevc3.o strexc.o strrfs.o strsen.o strsna.o strsyl.o \ + strti2.o strtri.o strtrs.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 \ + sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \ + sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \ + sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \ + stpqrt.o stpqrt2.o stpmqrt.o stprfb.o \ + sgelqt.o sgelqt3.o sgemlqt.o \ + sgetsls.o sgetsqrhrt.o sgeqr.o slatsqr.o slamtsqr.o sgemqr.o \ + sgelq.o slaswlq.o slamswlq.o sgemlq.o \ + stplqt.o stplqt2.o stpmlqt.o \ + sorhr_col.o slaorhr_col_getrfnp.o slaorhr_col_getrfnp2.o \ + ssytrd_2stage.o ssytrd_sy2sb.o ssytrd_sb2st.o ssb2st_kernels.o \ + ssyevd_2stage.o ssyev_2stage.o ssyevx_2stage.o ssyevr_2stage.o \ + ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o \ + sgesvdq.o slatrs3.o strsyl3.o sgelst.o sgedmd.o sgedmdq.o + +endif + +ifneq "$(or $(BUILD_SINGLE),$(BUILD_DOUBLE))" "" +DSLASRC_O = spotrs.o sgetrs.o spotrf.o sgetrf.o +endif + +ifdef USEXBLAS +SXLASRC = sgesvxx.o sgerfsx.o sla_gerfsx_extended.o sla_geamv.o \ + sla_gercond.o sla_gerpvgrw.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 +endif + +ifeq ($(BUILD_COMPLEX),1) +CLASRC_O = \ + cpotrf2.o cgetrf2.o \ + cbdsqr.o cgbbrd.o cgbcon.o cgbequ.o cgbrfs.o cgbsv.o cgbsvx.o \ + cgbtf2.o cgbtrf.o cgbtrs.o cgebak.o cgebal.o cgebd2.o cgebrd.o \ + cgecon.o cgeequ.o cgees.o cgeesx.o cgeev.o cgeevx.o \ + cgehd2.o cgehrd.o cgelq2.o cgelqf.o \ + cgels.o cgelsd.o cgelss.o cgelsy.o cgeql2.o cgeqlf.o cgeqp3.o cgeqp3rk.o \ + cgeqr2.o cgeqr2p.o cgeqrf.o cgeqrfp.o cgerfs.o \ + cgerq2.o cgerqf.o cgesc2.o cgesdd.o cgesv.o cgesvd.o cgesvdx.o \ + cgesvj.o cgejsv.o cgsvj0.o cgsvj1.o \ + cgesvx.o cgetc2.o cgetf2.o cgetri.o \ + cggbak.o cggbal.o cgges.o cgges3.o cggesx.o \ + cggev.o cggev3.o cggevx.o cggglm.o \ + cgghrd.o cgghd3.o cgglse.o cggqrf.o cggrqf.o \ + cggsvd3.o cggsvp3.o \ + cgtcon.o cgtrfs.o cgtsv.o cgtsvx.o cgttrf.o cgttrs.o cgtts2.o chbev.o \ + chbevd.o chbevx.o chbgst.o chbgv.o chbgvd.o chbgvx.o chbtrd.o \ + checon.o cheev.o cheevd.o cheevr.o cheevx.o chegs2.o chegst.o \ + chegv.o chegvd.o chegvx.o cherfs.o chesv.o chesvx.o chetd2.o \ + chetf2.o chetrd.o \ + chetrf.o chetri.o chetri2.o chetri2x.o cheswapr.o \ + chetrs.o chetrs2.o \ + chetf2_rook.o chetrf_rook.o chetri_rook.o \ + chetrs_rook.o checon_rook.o chesv_rook.o \ + chetf2_rk.o chetrf_rk.o chetri_3.o chetri_3x.o \ + chetrs_3.o checon_3.o chesv_rk.o \ + chesv_aa.o chetrf_aa.o chetrs_aa.o clahef_aa.o \ + chesv_aa_2stage.o chetrf_aa_2stage.o chetrs_aa_2stage.o \ + chgeqz.o chpcon.o chpev.o chpevd.o \ + chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.o \ + chpsvx.o \ + chptrd.o chptrf.o chptri.o chptrs.o chsein.o chseqr.o clabrd.o \ + clacgv.o clacon.o clacn2.o clacp2.o clacpy.o clacrm.o clacrt.o cladiv.o \ + claed0.o claed7.o claed8.o \ + claein.o claesy.o claev2.o clags2.o clagtm.o \ + clahef.o clahef_rook.o clahef_rk.o clahqr.o \ + clahr2.o claic1.o clals0.o clalsa.o clalsd.o clangb.o clange.o clangt.o \ + clanhb.o clanhe.o \ + clanhp.o clanhs.o clanht.o clansb.o clansp.o clansy.o clantb.o \ + clantp.o clantr.o clapll.o clapmt.o clarcm.o claqgb.o claqge.o \ + claqhb.o claqhe.o claqhp.o claqp2.o claqp2rk.o claqp3rk.o claqps.o claqsb.o \ + claqr0.o claqr1.o claqr2.o claqr3.o claqr4.o claqr5.o \ + claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \ + claqz0.o claqz1.o claqz2.o claqz3.o \ + clarf.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ + clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ + clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ + claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ + clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \ + clauu2.o clauum.o cpbcon.o cpbequ.o cpbrfs.o cpbstf.o cpbsv.o \ + cpbsvx.o cpbtf2.o cpbtrf.o cpbtrs.o cpocon.o cpoequ.o cporfs.o \ + cposv.o cposvx.o cpotf2.o cpotri.o cpstrf.o cpstf2.o \ + cppcon.o cppequ.o cpprfs.o cppsv.o cppsvx.o cpptrf.o cpptri.o cpptrs.o \ + cptcon.o cpteqr.o cptrfs.o cptsv.o cptsvx.o cpttrf.o cpttrs.o cptts2.o \ + crot.o crscl.o cspcon.o cspmv.o cspr.o csprfs.o cspsv.o \ + cspsvx.o csptrf.o csptri.o csptrs.o csrscl.o cstedc.o \ + cstegr.o cstein.o csteqr.o \ + csycon.o csymv.o \ + csyr.o csyrfs.o csysv.o csysvx.o csytf2.o csytrf.o csytri.o csytri2.o csytri2x.o \ + csyswapr.o csytrs.o csytrs2.o \ + csyconv.o csyconvf.o csyconvf_rook.o \ + csytf2_rook.o csytrf_rook.o csytrs_rook.o \ + csytri_rook.o csycon_rook.o csysv_rook.o \ + csytf2_rk.o csytrf_rk.o csytrf_aa.o csytrs_3.o csytrs_aa.o \ + csytri_3.o csytri_3x.o csycon_3.o csysv_rk.o csysv_aa.o \ + csysv_aa_2stage.o csytrf_aa_2stage.o csytrs_aa_2stage.o \ + ctbcon.o ctbrfs.o ctbtrs.o ctgevc.o ctgex2.o \ + ctgexc.o ctgsen.o ctgsja.o ctgsna.o ctgsy2.o ctgsyl.o ctpcon.o \ + ctprfs.o ctptri.o \ + ctptrs.o ctrcon.o ctrevc.o ctrevc3.o ctrexc.o ctrrfs.o ctrsen.o ctrsna.o \ + ctrsyl.o ctrti2.o ctrtri.o ctrtrs.o ctzrzf.o cung2l.o cung2r.o \ + cungbr.o cunghr.o cungl2.o cunglq.o cungql.o cungqr.o cungr2.o \ + cungrq.o cungtr.o cungtsqr.o cungtsqr_row.o cunm2l.o cunm2r.o cunmbr.o cunmhr.o cunml2.o cunm22.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 \ + 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 \ + cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \ + cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \ + cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \ + ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o \ + cgelqt.o cgelqt3.o cgemlqt.o \ + cgetsls.o cgetsqrhrt.o cgeqr.o clatsqr.o clamtsqr.o cgemqr.o \ + cgelq.o claswlq.o clamswlq.o cgemlq.o \ + ctplqt.o ctplqt2.o ctpmlqt.o \ + cunhr_col.o claunhr_col_getrfnp.o claunhr_col_getrfnp2.o \ + chetrd_2stage.o chetrd_he2hb.o chetrd_hb2st.o chb2st_kernels.o \ + cheevd_2stage.o cheev_2stage.o cheevx_2stage.o cheevr_2stage.o \ + chbev_2stage.o chbevx_2stage.o chbevd_2stage.o chegv_2stage.o \ + cgesvdq.o clatrs3.o ctrsyl3.o cgelst.o cgedmd.o cgedmdq.o +endif + +ifdef USEXBLAS +CXLASRC = cgesvxx.o cgerfsx.o cla_gerfsx_extended.o cla_geamv.o \ + cla_gercond_c.o cla_gercond_x.o cla_gerpvgrw.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 +endif + +ifneq "$(or $(BUILD_COMPLEX),$(BUILD_COMPLEX16))" "" +ZCLASRC_O = cpotrs.o cgetrs.o cpotrf.o cgetrf.o clag2z.o +endif + +ifeq ($(BUILD_DOUBLE),1) +DLASRC_O = \ + dpotrf2.o dgetrf2.o \ + dgbbrd.o dgbcon.o dgbequ.o dgbrfs.o dgbsv.o \ + dgbsvx.o dgbtf2.o dgbtrf.o dgbtrs.o dgebak.o dgebal.o dgebd2.o \ + dgebrd.o dgecon.o dgeequ.o dgees.o dgeesx.o dgeev.o dgeevx.o \ + dgehd2.o dgehrd.o dgelq2.o dgelqf.o \ + dgels.o dgelsd.o dgelss.o dgelsy.o dgeql2.o dgeqlf.o \ + dgeqp3.o dgeqp3rk.o dgeqr2.o dgeqr2p.o dgeqrf.o dgeqrfp.o dgerfs.o \ + dgerq2.o dgerqf.o dgesc2.o dgesdd.o dgesv.o dgesvd.o dgesvdx.o dgesvx.o \ + dgetc2.o dgetf2.o dgetrf.o dgetri.o \ + dgetrs.o dggbak.o dggbal.o dgges.o dgges3.o dggesx.o \ + dggev.o dggev3.o dggevx.o \ + dggglm.o dgghrd.o dgghd3.o dgglse.o dggqrf.o \ + dggrqf.o dggsvd3.o dggsvp3.o dgtcon.o dgtrfs.o dgtsv.o \ + dgtsvx.o dgttrf.o dgttrs.o dgtts2.o dhgeqz.o \ + dlaqz0.o dlaqz1.o dlaqz2.o dlaqz3.o dlaqz4.o \ + dhsein.o dhseqr.o dlabrd.o dlacon.o dlacn2.o \ + dlaein.o dlaexc.o dlag2.o dlags2.o dlagtm.o dlagv2.o dlahqr.o \ + dlahr2.o dlaic1.o dlaln2.o dlals0.o dlalsa.o dlalsd.o \ + dlangb.o dlange.o dlangt.o dlanhs.o dlansb.o dlansp.o \ + dlansy.o dlantb.o dlantp.o dlantr.o dlanv2.o \ + dlapll.o dlapmt.o \ + dlaqgb.o dlaqge.o dlaqp2.o dlaqp2rk.o dlaqp3rk.o dlaqps.o dlaqsb.o dlaqsp.o dlaqsy.o \ + dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ + dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ + dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ + dlarf1f.o dlarf1l.o dlargv.o dlarrv.o dlartv.o \ + dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ + dlasyf.o dlasyf_rook.o dlasyf_rk.o \ + dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlauu2.o \ + dlauum.o dopgtr.o dopmtr.o dorg2l.o dorg2r.o \ + dorgbr.o dorghr.o dorgl2.o dorglq.o dorgql.o dorgqr.o dorgr2.o \ + dorgrq.o dorgtr.o dorgtsqr.o dorgtsqr_row.o dorm2l.o dorm2r.o dorm22.o \ + dormbr.o dormhr.o dorml2.o dormlq.o dormql.o dormqr.o dormr2.o \ + 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 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 \ + dsbtrd.o dspcon.o dspev.o dspevd.o dspevx.o dspgst.o \ + dspgv.o dspgvd.o dspgvx.o dsprfs.o dspsv.o dspsvx.o dsptrd.o \ + dsptrf.o dsptri.o dsptrs.o dstegr.o dstev.o dstevd.o dstevr.o \ + dsycon.o dsyev.o dsyevd.o dsyevr.o \ + dsyevx.o dsygs2.o dsygst.o dsygv.o dsygvd.o dsygvx.o dsyrfs.o \ + dsysv.o dsysvx.o \ + dsytd2.o dsytf2.o dsytrd.o dsytrf.o dsytri.o dsytri2.o dsytri2x.o \ + dsyswapr.o dsytrs.o dsytrs2.o \ + dsyconv.o dsyconvf.o dsyconvf_rook.o \ + dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \ + dsytri_rook.o dsycon_rook.o dsysv_rook.o \ + dsytf2_rk.o dsytrf_rk.o dsytrs_3.o \ + dsytri_3.o dsytri_3x.o dsycon_3.o dsysv_rk.o \ + dlasyf_aa.o dsysv_aa.o dsytrf_aa.o dsytrs_aa.o \ + dsysv_aa_2stage.o dsytrf_aa_2stage.o dsytrs_aa_2stage.o \ + dtbcon.o dtbrfs.o dtbtrs.o dtgevc.o dtgex2.o dtgexc.o dtgsen.o \ + dtgsja.o dtgsna.o dtgsy2.o dtgsyl.o dtpcon.o dtprfs.o dtptri.o \ + dtptrs.o \ + dtrcon.o dtrevc.o dtrevc3.o dtrexc.o dtrrfs.o dtrsen.o dtrsna.o dtrsyl.o \ + dtrti2.o dtrtri.o dtrtrs.o dtzrzf.o dstemr.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 \ + dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \ + dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \ + dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \ + dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o \ + dgelqt.o dgelqt3.o dgemlqt.o \ + dgetsls.o dgetsqrhrt.o dgeqr.o dlatsqr.o dlamtsqr.o dgemqr.o \ + dgelq.o dlaswlq.o dlamswlq.o dgemlq.o \ + dtplqt.o dtplqt2.o dtpmlqt.o \ + dorhr_col.o dlaorhr_col_getrfnp.o dlaorhr_col_getrfnp2.o \ + dsytrd_2stage.o dsytrd_sy2sb.o dsytrd_sb2st.o dsb2st_kernels.o \ + dsyevd_2stage.o dsyev_2stage.o dsyevx_2stage.o dsyevr_2stage.o \ + dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o \ + dgesvdq.o dlatrs3.o dtrsyl3.o dgelst.o dgedmd.o dgedmdq.o +endif + +ifdef USEXBLAS +DXLASRC = dgesvxx.o dgerfsx.o dla_gerfsx_extended.o dla_geamv.o \ + dla_gercond.o dla_gerpvgrw.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 +endif + +ifeq ($(BUILD_COMPLEX16),1) +ZLASRC_O = \ + zpotrf2.o zgetrf2.o \ + zbdsqr.o zgbbrd.o zgbcon.o zgbequ.o zgbrfs.o zgbsv.o zgbsvx.o \ + zgbtf2.o zgbtrf.o zgbtrs.o zgebak.o zgebal.o zgebd2.o zgebrd.o \ + zgecon.o zgeequ.o zgees.o zgeesx.o zgeev.o zgeevx.o \ + zgehd2.o zgehrd.o zgelq2.o zgelqf.o \ + zgels.o zgelsd.o zgelss.o zgelsy.o zgeql2.o zgeqlf.o zgeqp3.o zgeqp3rk.o \ + zgeqr2.o zgeqr2p.o zgeqrf.o zgeqrfp.o zgerfs.o zgerq2.o zgerqf.o \ + zgesc2.o zgesdd.o zgesv.o zgesvd.o zgesvdx.o \ + zgesvj.o zgejsv.o zgsvj0.o zgsvj1.o \ + zgesvx.o zgetc2.o zgetf2.o zgetrf.o \ + zgetri.o zgetrs.o \ + zggbak.o zggbal.o zgges.o zgges3.o zggesx.o \ + zggev.o zggev3.o zggevx.o zggglm.o \ + zgghrd.o zgghd3.o zgglse.o zggqrf.o zggrqf.o \ + zggsvd3.o zggsvp3.o \ + zgtcon.o zgtrfs.o zgtsv.o zgtsvx.o zgttrf.o zgttrs.o zgtts2.o zhbev.o \ + zhbevd.o zhbevx.o zhbgst.o zhbgv.o zhbgvd.o zhbgvx.o zhbtrd.o \ + zhecon.o zheev.o zheevd.o zheevr.o zheevx.o zhegs2.o zhegst.o \ + zhegv.o zhegvd.o zhegvx.o zherfs.o zhesv.o zhesvx.o zhetd2.o \ + zhetf2.o zhetrd.o \ + zhetrf.o zhetri.o zhetri2.o zhetri2x.o zheswapr.o \ + zhetrs.o zhetrs2.o \ + zhetf2_rook.o zhetrf_rook.o zhetri_rook.o \ + zhetrs_rook.o zhecon_rook.o zhesv_rook.o \ + zhetf2_rk.o zhetrf_rk.o zhetri_3.o zhetri_3x.o \ + zhetrs_3.o zhecon_3.o zhesv_rk.o \ + zhesv_aa.o zhetrf_aa.o zhetrs_aa.o zlahef_aa.o \ + zhesv_aa_2stage.o zhetrf_aa_2stage.o zhetrs_aa_2stage.o \ + zhgeqz.o zhpcon.o zhpev.o zhpevd.o \ + zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.o \ + zhpsvx.o \ + zhptrd.o zhptrf.o zhptri.o zhptrs.o zhsein.o zhseqr.o zlabrd.o \ + zlacgv.o zlacon.o zlacn2.o zlacp2.o zlacpy.o zlacrm.o zlacrt.o zladiv.o \ + zlaed0.o zlaed7.o zlaed8.o \ + zlaein.o zlaesy.o zlaev2.o zlags2.o zlagtm.o \ + zlahef.o zlahef_rook.o zlahef_rk.o zlahqr.o \ + zlahr2.o zlaic1.o zlals0.o zlalsa.o zlalsd.o zlangb.o zlange.o \ + zlangt.o zlanhb.o \ + zlanhe.o \ + zlanhp.o zlanhs.o zlanht.o zlansb.o zlansp.o zlansy.o zlantb.o \ + zlantp.o zlantr.o zlapll.o zlapmt.o zlaqgb.o zlaqge.o \ + zlaqhb.o zlaqhe.o zlaqhp.o zlaqp2.o zlaqp2rk.o zlaqp3rk.o zlaqps.o zlaqsb.o \ + zlaqr0.o zlaqr1.o zlaqr2.o zlaqr3.o zlaqr4.o zlaqr5.o \ + zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \ + zlaqz0.o zlaqz1.o zlaqz2.o zlaqz3.o \ + zlarcm.o zlarf.o zlarfb.o zlarfb_gett.o \ + zlarfg.o zlarft.o zlarfgp.o zlarf1f.o zlarf1l.o \ + zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \ + zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ + zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.o zlasyf_aa.o \ + zlatbs.o zlatdf.o zlatps.o zlatrd.o zlatrs.o zlatrz.o zlauu2.o \ + zlauum.o zpbcon.o zpbequ.o zpbrfs.o zpbstf.o zpbsv.o \ + zpbsvx.o zpbtf2.o zpbtrf.o zpbtrs.o zpocon.o zpoequ.o zporfs.o \ + zposv.o zposvx.o zpotf2.o zpotrf.o zpotri.o zpotrs.o zpstrf.o zpstf2.o \ + zppcon.o zppequ.o zpprfs.o zppsv.o zppsvx.o zpptrf.o zpptri.o zpptrs.o \ + zptcon.o zpteqr.o zptrfs.o zptsv.o zptsvx.o zpttrf.o zpttrs.o zptts2.o \ + zrot.o zrscl.o zspcon.o zspmv.o zspr.o zsprfs.o zspsv.o \ + zspsvx.o zsptrf.o zsptri.o zsptrs.o zdrscl.o zstedc.o \ + zstegr.o zstein.o zsteqr.o \ + zsycon.o zsymv.o \ + zsyr.o zsyrfs.o zsysv.o zsysvx.o zsytf2.o zsytrf.o zsytri.o zsytri2.o zsytri2x.o \ + zsyswapr.o zsytrs.o zsytrs2.o \ + zsyconv.o zsyconvf.o zsyconvf_rook.o \ + zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o zsytrs_aa.o \ + zsytri_rook.o zsycon_rook.o zsysv_rook.o \ + zsysv_aa_2stage.o zsytrf_aa_2stage.o zsytrs_aa_2stage.o \ + zsytf2_rk.o zsytrf_rk.o zsytrf_aa.o zsytrs_3.o \ + zsytri_3.o zsytri_3x.o zsycon_3.o zsysv_rk.o zsysv_aa.o \ + ztbcon.o ztbrfs.o ztbtrs.o ztgevc.o ztgex2.o \ + ztgexc.o ztgsen.o ztgsja.o ztgsna.o ztgsy2.o ztgsyl.o ztpcon.o \ + ztprfs.o ztptri.o \ + ztptrs.o ztrcon.o ztrevc.o ztrevc3.o ztrexc.o ztrrfs.o ztrsen.o ztrsna.o \ + ztrsyl.o ztrti2.o ztrtri.o ztrtrs.o ztzrzf.o zung2l.o \ + zung2r.o zungbr.o zunghr.o zungl2.o zunglq.o zungql.o zungqr.o zungr2.o \ + zungrq.o zungtr.o zungtsqr.o zungtsqr_row.o zunm2l.o zunm2r.o zunmbr.o zunmhr.o zunml2.o zunm22.o \ + 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 zcposv.o zlag2c.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 \ + zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \ + zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \ + zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \ + ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o \ + ztplqt.o ztplqt2.o ztpmlqt.o \ + zgelqt.o zgelqt3.o zgemlqt.o \ + zgetsls.o zgetsqrhrt.o zgeqr.o zlatsqr.o zlamtsqr.o zgemqr.o \ + zgelq.o zlaswlq.o zlamswlq.o zgemlq.o \ + zunhr_col.o zlaunhr_col_getrfnp.o zlaunhr_col_getrfnp2.o \ + zhetrd_2stage.o zhetrd_he2hb.o zhetrd_hb2st.o zhb2st_kernels.o \ + zheevd_2stage.o zheev_2stage.o zheevx_2stage.o zheevr_2stage.o \ + zhbev_2stage.o zhbevx_2stage.o zhbevd_2stage.o zhegv_2stage.o \ + zgesvdq.o zlatrs3.o ztrsyl3.o zgelst.o zgedmd.o zgedmdq.o +endif + +ifdef USEXBLAS +ZXLASRC = zgesvxx.o zgerfsx.o zla_gerfsx_extended.o zla_geamv.o \ + zla_gercond_c.o zla_gercond_x.o zla_gerpvgrw.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 +endif + +ifeq ($(BUILD_COMPLEX),1) +CDEPRECSRC = DEPRECATED/cgegs.o DEPRECATED/cgegv.o DEPRECATED/cgelsx.o \ + DEPRECATED/cgeqpf.o DEPRECATED/cggsvd.o DEPRECATED/cggsvp.o \ + DEPRECATED/clahrd.o DEPRECATED/clatzm.o DEPRECATED/ctzrqf.o \ + DEPRECATED/cgelqs.o DEPRECATED/cgeqrs.o +endif + +ifeq ($(BUILD_DOUBLE),1) +DDEPRECSRC = \ + DEPRECATED/dgegs.o DEPRECATED/dgegv.o DEPRECATED/dgelsx.o \ + DEPRECATED/dgeqpf.o DEPRECATED/dggsvd.o DEPRECATED/dggsvp.o \ + DEPRECATED/dlahrd.o DEPRECATED/dlatzm.o DEPRECATED/dtzrqf.o \ + DEPRECATED/dgelqs.o DEPRECATED/dgeqrs.o +endif +ifeq ($(BUILD_SINGLE),1) +SDEPRECSRC = \ + DEPRECATED/sgegs.o DEPRECATED/sgegv.o DEPRECATED/sgelsx.o \ + DEPRECATED/sgeqpf.o DEPRECATED/sggsvd.o DEPRECATED/sggsvp.o \ + DEPRECATED/slahrd.o DEPRECATED/slatzm.o DEPRECATED/stzrqf.o \ + DEPRECATED/sgelqs.o DEPRECATED/sgeqrs.o +endif +ifeq ($(BUILD_COMPLEX16),1) +ZDEPRECSRC = \ + DEPRECATED/zgegs.o DEPRECATED/zgegv.o DEPRECATED/zgelsx.o \ + DEPRECATED/zgeqpf.o DEPRECATED/zggsvd.o DEPRECATED/zggsvp.o \ + DEPRECATED/zlahrd.o DEPRECATED/zlatzm.o DEPRECATED/ztzrqf.o \ + DEPRECATED/zgelqs.o DEPRECATED/zgeqrs.o +endif + +# filter out optimized codes from OpenBLAS +ALL_AUX_OBJS = xerbla.o ../INSTALL/lsame.o +SCL_AUX_OBJS = slaed3.o +DZL_AUX_OBJS = dlaed3.o + +SLAPACKOBJS = \ + sgetrf.o sgetrs.o spotrf.o sgetf2.o \ + spotf2.o slaswp.o sgesv.o slauu2.o \ + slauum.o strti2.o strtri.o strtrs.o \ + ssymv.o ssyr.o sspmv.o sspr.o + +DLAPACKOBJS = \ + dgetrf.o dgetrs.o dpotrf.o dgetf2.o \ + dpotf2.o dlaswp.o dgesv.o dlauu2.o \ + dlauum.o dtrti2.o dtrtri.o dtrtrs.o \ + dsymv.o dsyr.o dspmv.o dspr.o + +CLAPACKOBJS = \ + cgetrf.o cgetrs.o cpotrf.o cgetf2.o \ + cpotf2.o claswp.o cgesv.o clauu2.o \ + clauum.o ctrti2.o ctrtri.o ctrtrs.o \ + csymv.o csyr.o cspmv.o cspr.o + +ZLAPACKOBJS = \ + zgetrf.o zgetrs.o zpotrf.o zgetf2.o \ + zpotf2.o zlaswp.o zgesv.o zlauu2.o \ + zlauum.o ztrti2.o ztrtri.o ztrtrs.o \ + zsymv.o zsyr.o zspmv.o zspr.o + +ALLAUX = $(filter-out $(ALL_AUX_OBJS),$(ALLAUX_O)) +SCLAUX = $(filter-out $(SCL_AUX_OBJS),$(SCLAUX_O)) +DZLAUX = $(filter-out $(DZL_AUX_OBJS),$(DZLAUX_O)) +SLASRC = $(filter-out $(SLAPACKOBJS),$(SLASRC_O)) +DLASRC = $(filter-out $(DLAPACKOBJS),$(DLASRC_O)) +CLASRC = $(filter-out $(CLAPACKOBJS),$(CLASRC_O)) +ZLASRC = $(filter-out $(ZLAPACKOBJS),$(ZLASRC_O)) +DSLASRC = $(filter-out $(SLAPACKOBJS),$(DSLASRC_O)) +ZCLASRC = $(filter-out $(CLAPACKOBJS),$(ZCLASRC_O)) + +#from commit 1046, supposedly related to mingw but breaks thread safety +#in insiduous ways on all platforms when used in place of OPTS below +#OPTS1 = $(filter-out -fopenmp, $(OPTS)) +#end filter out + + +ALLOBJ = $(SLASRC) $(DLASRC) $(DSLASRC) $(CLASRC) $(ZLASRC) $(ZCLASRC) \ + $(SCLAUX) $(DZLAUX) $(ALLAUX) + +ifdef USEXBLAS +ALLXOBJ = $(SXLASRC) $(DXLASRC) $(CXLASRC) $(ZXLASRC) +endif + +ifdef BUILD_DEPRECATED +DEPRECATED = $(SDEPRECSRC) $(DDEPRECSRC) $(CDEPRECSRC) $(ZDEPRECSRC) +endif + .PHONY: all -all: lapack_install lib blas_testing lapack_testing - -.PHONY: lib -lib: lapacklib tmglib -#lib: blaslib variants lapacklib tmglib - -.PHONY: blaslib -blaslib: - $(MAKE) -C BLAS - -.PHONY: cblaslib -cblaslib: - $(MAKE) -C CBLAS - -.PHONY: lapacklib -lapacklib: - $(MAKE) -C SRC - -.PHONY: lapackelib -lapackelib: - $(MAKE) -C LAPACKE - -.PHONY: blaspplib -blaspplib: - @echo "Thank you for your interest in BLAS++, a newly developed C++ API for BLAS library" - @echo "The objective of BLAS++ is to provide a convenient, performance oriented API for development in the C++ language, that, for the most part, preserves established conventions, while, at the same time, takes advantages of modern C++ features, such as: namespaces, templates, exceptions, etc." - @echo "We are still working on integrating BLAS++ in our library. For the moment, you can download directly blas++ from https://bitbucket.org/icl/blaspp" - @echo "For support BLAS++ related question, please email: slate-user@icl.utk.edu" - -.PHONY: lapackpplib -lapackpplib: - @echo "Thank you for your interest in LAPACK++, a newly developed C++ API for LAPACK library" - @echo "The objective of LAPACK++ is to provide a convenient, performance oriented API for development in the C++ language, that, for the most part, preserves established conventions, while, at the same time, takes advantages of modern C++ features, such as: namespaces, templates, exceptions, etc." - @echo "We are still working on integrating LAPACK++ in our library. For the moment, you can download directly lapack++ from https://bitbucket.org/icl/lapackpp" - @echo "For support LAPACK++ related question, please email: slate-user@icl.utk.edu" - -.PHONY: tmglib -tmglib: - $(MAKE) -C TESTING/MATGEN - -.PHONY: variants -variants: - $(MAKE) -C SRC/VARIANTS - -.PHONY: lapack_install -lapack_install: - $(MAKE) -C INSTALL run - -.PHONY: blas_testing -blas_testing: blaslib - $(MAKE) -C BLAS blas_testing - -.PHONY: cblas_testing -cblas_testing: cblaslib blaslib - $(MAKE) -C CBLAS cblas_testing - -.PHONY: lapack_testing -lapack_testing: tmglib lapacklib blaslib - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING - ./lapack_testing.py - -.PHONY: variants_testing -variants_testing: tmglib variants lapacklib blaslib - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/LIN VARLIB='../../SRC/VARIANTS/cholrl.a' - $(MAKE) -C TESTING stest.out && mv TESTING/stest.out TESTING/stest_cholrl.out - $(MAKE) -C TESTING dtest.out && mv TESTING/dtest.out TESTING/dtest_cholrl.out - $(MAKE) -C TESTING ctest.out && mv TESTING/ctest.out TESTING/ctest_cholrl.out - $(MAKE) -C TESTING ztest.out && mv TESTING/ztest.out TESTING/ztest_cholrl.out - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/LIN VARLIB='../../SRC/VARIANTS/choltop.a' - $(MAKE) -C TESTING stest.out && mv TESTING/stest.out TESTING/stest_choltop.out - $(MAKE) -C TESTING dtest.out && mv TESTING/dtest.out TESTING/dtest_choltop.out - $(MAKE) -C TESTING ctest.out && mv TESTING/ctest.out TESTING/ctest_choltop.out - $(MAKE) -C TESTING ztest.out && mv TESTING/ztest.out TESTING/ztest_choltop.out - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/LIN VARLIB='../../SRC/VARIANTS/lucr.a' - $(MAKE) -C TESTING stest.out && mv TESTING/stest.out TESTING/stest_lucr.out - $(MAKE) -C TESTING dtest.out && mv TESTING/dtest.out TESTING/dtest_lucr.out - $(MAKE) -C TESTING ctest.out && mv TESTING/ctest.out TESTING/ctest_lucr.out - $(MAKE) -C TESTING ztest.out && mv TESTING/ztest.out TESTING/ztest_lucr.out - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/LIN VARLIB='../../SRC/VARIANTS/lull.a' - $(MAKE) -C TESTING stest.out && mv TESTING/stest.out TESTING/stest_lull.out - $(MAKE) -C TESTING dtest.out && mv TESTING/dtest.out TESTING/dtest_lull.out - $(MAKE) -C TESTING ctest.out && mv TESTING/ctest.out TESTING/ctest_lull.out - $(MAKE) -C TESTING ztest.out && mv TESTING/ztest.out TESTING/ztest_lull.out - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/LIN VARLIB='../../SRC/VARIANTS/lurec.a' - $(MAKE) -C TESTING stest.out && mv TESTING/stest.out TESTING/stest_lurec.out - $(MAKE) -C TESTING dtest.out && mv TESTING/dtest.out TESTING/dtest_lurec.out - $(MAKE) -C TESTING ctest.out && mv TESTING/ctest.out TESTING/ctest_lurec.out - $(MAKE) -C TESTING ztest.out && mv TESTING/ztest.out TESTING/ztest_lurec.out - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/LIN VARLIB='../../SRC/VARIANTS/qrll.a' - $(MAKE) -C TESTING stest.out && mv TESTING/stest.out TESTING/stest_qrll.out - $(MAKE) -C TESTING dtest.out && mv TESTING/dtest.out TESTING/dtest_qrll.out - $(MAKE) -C TESTING ctest.out && mv TESTING/ctest.out TESTING/ctest_qrll.out - $(MAKE) -C TESTING ztest.out && mv TESTING/ztest.out TESTING/ztest_qrll.out - -.PHONY: cblas_example -cblas_example: cblaslib blaslib - $(MAKE) -C CBLAS cblas_example - -.PHONY: lapacke_example -lapacke_example: lapackelib lapacklib blaslib - $(MAKE) -C LAPACKE lapacke_example - -.PHONY: html -html: - @echo "LAPACK HTML PAGES GENERATION with Doxygen" - doxygen DOCS/Doxyfile - @echo "==================" - @echo "LAPACK HTML PAGES GENERATED in DOCS/explore-html" - @echo "Usage: open DOCS/explore-html/index.html" - @echo "Online version available at http://www.netlib.org/lapack/explore-html/" - @echo "==================" - -.PHONY: man -man: - @echo "LAPACK MAN PAGES GENERATION with Doxygen" - doxygen DOCS/Doxyfile_man - @echo "==================" - @echo "LAPACK MAN PAGES GENERATED in DOCS/MAN" - @echo "Set your MANPATH env variable accordingly" - @echo "Usage: man dgetrf.f" - @echo "==================" - -.PHONY: clean cleanobj cleanlib cleanexe cleantest -clean: - $(MAKE) -C INSTALL clean - $(MAKE) -C BLAS clean - $(MAKE) -C CBLAS clean - $(MAKE) -C SRC clean - $(MAKE) -C SRC/VARIANTS clean - $(MAKE) -C TESTING clean - $(MAKE) -C TESTING/MATGEN clean - $(MAKE) -C TESTING/LIN clean - $(MAKE) -C TESTING/EIG clean - $(MAKE) -C LAPACKE clean - rm -f *.a +all: $(LAPACKLIB) + +$(LAPACKLIB): $(ALLOBJ) $(ALLXOBJ) $(DEPRECATED) + $(AR) $(ARFLAGS) $@ $^ + $(RANLIB) $@ + +.PHONY: single complex double complex16 +single: $(SLASRC) $(DSLASRC) $(SXLASRC) $(SCLAUX) $(ALLAUX) + $(AR) $(ARFLAGS) $(LAPACKLIB) $^ + $(RANLIB) $(LAPACKLIB) + +complex: $(CLASRC) $(ZCLASRC) $(CXLASRC) $(SCLAUX) $(ALLAUX) + $(AR) $(ARFLAGS) $(LAPACKLIB) $^ + $(RANLIB) $(LAPACKLIB) + +double: $(DLASRC) $(DSLASRC) $(DXLASRC) $(DZLAUX) $(ALLAUX) + $(AR) $(ARFLAGS) $(LAPACKLIB) $^ + $(RANLIB) $(LAPACKLIB) + +complex16: $(ZLASRC) $(ZCLASRC) $(ZXLASRC) $(DZLAUX) $(ALLAUX) + $(AR) $(ARFLAGS) $(LAPACKLIB) $^ + $(RANLIB) $(LAPACKLIB) + +$(ALLAUX): $(FRC) +$(SCLAUX): $(FRC) +$(DZLAUX): $(FRC) +$(SLASRC): $(FRC) +$(CLASRC): $(FRC) +$(DLASRC): $(FRC) +$(ZLASRC): $(FRC) +$(ZCLASRC): $(FRC) +$(DSLASRC): $(FRC) +ifdef USEXBLAS +$(SXLASRC): $(FRC) +$(CXLASRC): $(FRC) +$(DXLASRC): $(FRC) +$(ZXLASRC): $(FRC) +endif + +FRC: + @FRC=$(FRC) + +.PHONY: clean cleanobj cleanlib +clean: cleanobj cleanlib cleanobj: - $(MAKE) -C INSTALL cleanobj - $(MAKE) -C BLAS cleanobj - $(MAKE) -C CBLAS cleanobj - $(MAKE) -C SRC cleanobj - $(MAKE) -C SRC/VARIANTS cleanobj - $(MAKE) -C TESTING/MATGEN cleanobj - $(MAKE) -C TESTING/LIN cleanobj - $(MAKE) -C TESTING/EIG cleanobj - $(MAKE) -C LAPACKE cleanobj + rm -f *.o *.mod DEPRECATED/*.o DEPRECATED/*.mod cleanlib: - $(MAKE) -C BLAS cleanlib - $(MAKE) -C CBLAS cleanlib - $(MAKE) -C SRC cleanlib - $(MAKE) -C SRC/VARIANTS cleanlib - $(MAKE) -C TESTING/MATGEN cleanlib - $(MAKE) -C LAPACKE cleanlib - rm -f *.a -cleanexe: - $(MAKE) -C INSTALL cleanexe - $(MAKE) -C BLAS cleanexe - $(MAKE) -C CBLAS cleanexe - $(MAKE) -C TESTING/LIN cleanexe - $(MAKE) -C TESTING/EIG cleanexe - $(MAKE) -C LAPACKE cleanexe -cleantest: - $(MAKE) -C INSTALL cleantest - $(MAKE) -C BLAS cleantest - $(MAKE) -C CBLAS cleantest - $(MAKE) -C TESTING cleantest \ No newline at end of file + rm -f $(LAPACKLIB) + +ifneq ($(C_LAPACK), 1) +slaruv.o: slaruv.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< +dlaruv.o: dlaruv.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< +sla_wwaddw.o: sla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< +dla_wwaddw.o: dla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< +cla_wwaddw.o: cla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< +zla_wwaddw.o: zla_wwaddw.f ; $(FC) $(FFLAGS_NOOPT) -c -o $@ $< +# Modules +la_xisnan.o: la_xisnan.F90 la_constants.mod + $(FC) $(FFLAGS) -c -o $@ $< +la_constants.o: la_constants.f90 + $(FC) $(FFLAGS) -c -o $@ $< +else +slaruv.o: slaruv.c ; $(CC) $(CFLAGS) -c -o $@ $< +dlaruv.o: dlaruv.c ; $(CC) $(CFLAGS) -c -o $@ $< +sla_wwaddw.o: sla_wwaddw.c ; $(CC) $(CFLAGS) -c -o $@ $< +dla_wwaddw.o: dla_wwaddw.c ; $(CC) $(CFLAGS) -c -o $@ $< +cla_wwaddw.o: cla_wwaddw.c ; $(CC) $(CFLAGS) -c -o $@ $< +zla_wwaddw.o: zla_wwaddw.c ; $(CC) $(CFLAGS) -c -o $@ $< +endif + diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 0f547dd0c4..ebf3431a92 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -155,7 +155,7 @@ SLASRC_O = \ slaqr0.o slaqr1.o slaqr2.o slaqr3.o slaqr4.o slaqr5.o \ slaqtr.o slar1v.o slar2v.o ilaslr.o ilaslc.o \ slarf.o slarfb.o slarfb_gett.o slarfg.o slarfgp.o slarft.o slarfx.o slarfy.o slargv.o \ - slarrv.o slartv.o \ + slarf1f.o slarf1l.o slarrv.o slartv.o \ slarz.o slarzb.o slarzt.o slaswp.o slasy2.o slasyf.o slasyf_rook.o \ slasyf_rk.o \ slatbs.o slatdf.o slatps.o slatrd.o slatrs.o slatrz.o \ @@ -271,6 +271,7 @@ CLASRC_O = \ claqsp.o claqsy.o clar1v.o clar2v.o ilaclr.o ilaclc.o \ claqz0.o claqz1.o claqz2.o claqz3.o \ clarf.o clarfb.o clarfb_gett.o clarfg.o clarft.o clarfgp.o \ + clarf1f.o clarf1l.o \ clarfx.o clarfy.o clargv.o clarnv.o clarrv.o clartg.o clartv.o \ clarz.o clarzb.o clarzt.o clascl.o claset.o clasr.o classq.o \ claswp.o clasyf.o clasyf_rook.o clasyf_rk.o clasyf_aa.o \ @@ -364,7 +365,7 @@ DLASRC_O = \ dlaqr0.o dlaqr1.o dlaqr2.o dlaqr3.o dlaqr4.o dlaqr5.o \ dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \ dlarf.o dlarfb.o dlarfb_gett.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o dlarfy.o \ - dlargv.o dlarrv.o dlartv.o \ + dlarf1f.o dlarf1l.o dlargv.o dlarrv.o dlartv.o \ dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o \ dlasyf.o dlasyf_rook.o dlasyf_rk.o \ dlatbs.o dlatdf.o dlatps.o dlatrd.o dlatrs.o dlatrz.o dlauu2.o \ @@ -478,7 +479,7 @@ ZLASRC_O = \ zlaqsp.o zlaqsy.o zlar1v.o zlar2v.o ilazlr.o ilazlc.o \ zlaqz0.o zlaqz1.o zlaqz2.o zlaqz3.o \ zlarcm.o zlarf.o zlarfb.o zlarfb_gett.o \ - zlarfg.o zlarft.o zlarfgp.o \ + zlarfg.o zlarft.o zlarfgp.o zlarf1f.o zlarf1l.o \ zlarfx.o zlarfy.o zlargv.o zlarnv.o zlarrv.o zlartg.o zlartv.o \ zlarz.o zlarzb.o zlarzt.o zlascl.o zlaset.o zlasr.o \ zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.o zlasyf_aa.o \ diff --git a/lapack-netlib/SRC/cgebd2.f b/lapack-netlib/SRC/cgebd2.f index db949f90cf..b9be813007 100644 --- a/lapack-netlib/SRC/cgebd2.f +++ b/lapack-netlib/SRC/cgebd2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEBD2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -132,7 +130,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup gebd2 * @precisions normal c -> s d z * *> \par Further Details: @@ -187,6 +185,7 @@ *> * ===================================================================== SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -203,16 +202,15 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * ===================================================================== * * .. Parameters .. - COMPLEX ZERO, ONE - PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), - $ ONE = ( 1.0E+0, 0.0E+0 ) ) + COMPLEX ZERO + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. INTEGER I COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CLARFG, XERBLA + EXTERNAL CLACGV, CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -246,13 +244,13 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = REAL( ALPHA ) - A( I, I ) = ONE * * Apply H(i)**H to A(i:m,i+1:n) from the left * IF( I.LT.N ) - $ CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + $ CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAUQ( I ) ), A( I, I+1 ), LDA, + $ WORK ) A( I, I ) = D( I ) * IF( I.LT.N ) THEN @@ -265,12 +263,11 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = REAL( ALPHA ) - A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * - CALL CLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) CALL CLACGV( N-I, A( I, I+1 ), LDA ) A( I, I+1 ) = E( I ) ELSE @@ -290,13 +287,12 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, $ TAUP( I ) ) D( I ) = REAL( ALPHA ) - A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) - $ CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) + $ CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) CALL CLACGV( N-I+1, A( I, I ), LDA ) A( I, I ) = D( I ) * @@ -309,13 +305,12 @@ SUBROUTINE CGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL CLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, $ TAUQ( I ) ) E( I ) = REAL( ALPHA ) - A( I+1, I ) = ONE * * Apply H(i)**H to A(i+1:m,i+1:n) from the left * - CALL CLARF( 'Left', M-I, N-I, A( I+1, I ), 1, - $ CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, - $ WORK ) + CALL CLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, + $ CONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, + $ WORK ) A( I+1, I ) = E( I ) ELSE TAUQ( I ) = ZERO diff --git a/lapack-netlib/SRC/cgehd2.f b/lapack-netlib/SRC/cgehd2.f index d8b40b180c..4a5400667f 100644 --- a/lapack-netlib/SRC/cgehd2.f +++ b/lapack-netlib/SRC/cgehd2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEHD2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -106,7 +104,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup gehd2 * *> \par Further Details: * ===================== @@ -146,6 +144,7 @@ *> * ===================================================================== SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -160,16 +159,11 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, XERBLA + EXTERNAL CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -197,21 +191,19 @@ SUBROUTINE CGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) * - ALPHA = A( I+1, I ) - CALL CLARFG( IHI-I, ALPHA, A( MIN( I+2, N ), I ), 1, TAU( I ) ) - A( I+1, I ) = ONE + CALL CLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * - CALL CLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), - $ A( 1, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i)**H to A(i+1:ihi,i+1:n) from the left * - CALL CLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, - $ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, + $ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) * - A( I+1, I ) = ALPHA 10 CONTINUE * RETURN diff --git a/lapack-netlib/SRC/cgelq2.f b/lapack-netlib/SRC/cgelq2.f index 0ea4a7200f..97bc676b17 100644 --- a/lapack-netlib/SRC/cgelq2.f +++ b/lapack-netlib/SRC/cgelq2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGELQ2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -104,7 +102,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup gelq2 * *> \par Further Details: * ===================== @@ -126,6 +124,7 @@ *> * ===================================================================== SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -140,16 +139,11 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CLARFG, XERBLA + EXTERNAL CLACGV, CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -178,18 +172,15 @@ SUBROUTINE CGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * Generate elementary reflector H(i) to annihilate A(i,i+1:n) * CALL CLACGV( N-I+1, A( I, I ), LDA ) - ALPHA = A( I, I ) - CALL CLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, + CALL CLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, $ TAU( I ) ) IF( I.LT.M ) THEN * * Apply H(i) to A(i+1:m,i:n) from the right * - A( I, I ) = ONE - CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) + CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF - A( I, I ) = ALPHA CALL CLACGV( N-I+1, A( I, I ), LDA ) 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/cgeql2.f b/lapack-netlib/SRC/cgeql2.f index 41a5f9e049..a089d267ac 100644 --- a/lapack-netlib/SRC/cgeql2.f +++ b/lapack-netlib/SRC/cgeql2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEQL2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -98,7 +96,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup geql2 * *> \par Further Details: * ===================== @@ -120,6 +118,7 @@ *> * ===================================================================== SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,16 +133,11 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, XERBLA + EXTERNAL CLARF1L, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -172,15 +166,13 @@ SUBROUTINE CGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * Generate elementary reflector H(i) to annihilate * A(1:m-k+i-1,n-k+i) * - ALPHA = A( M-K+I, N-K+I ) - CALL CLARFG( M-K+I, ALPHA, A( 1, N-K+I ), 1, TAU( I ) ) + CALL CLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1, + $ TAU( I ) ) * * Apply H(i)**H to A(1:m-k+i,1:n-k+i-1) from the left * - A( M-K+I, N-K+I ) = ONE - CALL CLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, - $ CONJG( TAU( I ) ), A, LDA, WORK ) - A( M-K+I, N-K+I ) = ALPHA + CALL CLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, + $ CONJG( TAU( I ) ), A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/cgeqp3rk.f b/lapack-netlib/SRC/cgeqp3rk.f index fecf8d85cc..2fda980adc 100644 --- a/lapack-netlib/SRC/cgeqp3rk.f +++ b/lapack-netlib/SRC/cgeqp3rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEQP3RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -552,27 +550,19 @@ *> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. *> A BLAS-3 version of the QR factorization with column pivoting. *> LAPACK Working Note 114 -*> \htmlonly *> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf -*> \endhtmlonly *> and in *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. -*> \htmlonly *> https://doi.org/10.1137/S1064827595296732 -*> \endhtmlonly *> *> [2] A partial column norm updating strategy developed in 2006. *> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. *> On the failure of rank revealing QR factorization software – a case study. *> LAPACK Working Note 176. -*> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf -*> \endhtmlonly *> and in *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. -*> \htmlonly *> https://doi.org/10.1145/1377612.1377616 -*> \endhtmlonly * *> \par Contributors: * ================== @@ -678,7 +668,7 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Minimal workspace size in case of using only unblocked * BLAS 2 code in CLAQP2RK. * 1) CLAQP2RK: N+NRHS-1 to use in WORK array that is used -* in CLARF subroutine inside CLAQP2RK to apply an +* in CLARF1F subroutine inside CLAQP2RK to apply an * elementary reflector from the left. * TOTAL_WORK_SIZE = 3*N + NRHS - 1 * @@ -694,7 +684,7 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 1) CGEQP3RK, CLAQP2RK, CLAQP3RK: 2*N to store full and * partial column 2-norms. * 2) CLAQP2RK: N+NRHS-1 to use in WORK array that is used -* in CLARF subroutine to apply an elementary reflector +* in CLARF1F subroutine to apply an elementary reflector * from the left. * 3) CLAQP3RK: NB*(N+NRHS) to use in the work array F that * is used to apply a block reflector from @@ -894,7 +884,8 @@ SUBROUTINE CGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Determine when to cross over from blocked to unblocked code. * (for N less than NX, unblocked code should be used). * - NX = MAX( 0, ILAENV( IXOVER, 'CGEQP3RK', ' ', M, N, -1, -1 ) ) + NX = MAX( 0, ILAENV( IXOVER, 'CGEQP3RK', ' ', M, N, -1, + $ -1 ) ) * IF( NX.LT.MINMN ) THEN * diff --git a/lapack-netlib/SRC/cgeqr2.f b/lapack-netlib/SRC/cgeqr2.f index b0b346b2db..775d33c515 100644 --- a/lapack-netlib/SRC/cgeqr2.f +++ b/lapack-netlib/SRC/cgeqr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEQR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -105,7 +103,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup geqr2 * *> \par Further Details: * ===================== @@ -127,6 +125,7 @@ *> * ===================================================================== SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -141,16 +140,11 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, XERBLA + EXTERNAL CLARF1F, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -184,11 +178,8 @@ SUBROUTINE CGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i)**H to A(i:m,i+1:n) from the left * - ALPHA = A( I, I ) - A( I, I ) = ONE - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) - A( I, I ) = ALPHA + CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/cgeqr2p.f b/lapack-netlib/SRC/cgeqr2p.f index 7be7e7a1c9..72e3945780 100644 --- a/lapack-netlib/SRC/cgeqr2p.f +++ b/lapack-netlib/SRC/cgeqr2p.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGEQR2P + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,7 +105,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup geqr2p * *> \par Further Details: * ===================== @@ -131,6 +129,7 @@ *> * ===================================================================== SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -145,16 +144,11 @@ SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, XERBLA + EXTERNAL CLARF1F, CLARFGP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, MIN @@ -188,11 +182,8 @@ SUBROUTINE CGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i)**H to A(i:m,i+1:n) from the left * - ALPHA = A( I, I ) - A( I, I ) = ONE - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, - $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) - A( I, I ) = ALPHA + CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/cgerq2.f b/lapack-netlib/SRC/cgerq2.f index a2cf5cf696..3b8a959387 100644 --- a/lapack-netlib/SRC/cgerq2.f +++ b/lapack-netlib/SRC/cgerq2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CGERQ2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -98,7 +96,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexGEcomputational +*> \ingroup gerq2 * *> \par Further Details: * ===================== @@ -120,6 +118,7 @@ *> * ===================================================================== SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,16 +133,11 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. INTEGER I, K - COMPLEX ALPHA * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CLARFG, XERBLA + EXTERNAL CLACGV, CLARF1L, CLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -173,16 +167,13 @@ SUBROUTINE CGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * A(m-k+i,1:n-k+i-1) * CALL CLACGV( N-K+I, A( M-K+I, 1 ), LDA ) - ALPHA = A( M-K+I, N-K+I ) - CALL CLARFG( N-K+I, ALPHA, A( M-K+I, 1 ), LDA, + CALL CLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, $ TAU( I ) ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * - A( M-K+I, N-K+I ) = ONE - CALL CLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, - $ TAU( I ), A, LDA, WORK ) - A( M-K+I, N-K+I ) = ALPHA + CALL CLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) CALL CLACGV( N-K+I-1, A( M-K+I, 1 ), LDA ) 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/claqp2.f b/lapack-netlib/SRC/claqp2.f index 6e41afeb4a..ea1e4edfcb 100644 --- a/lapack-netlib/SRC/claqp2.f +++ b/lapack-netlib/SRC/claqp2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAQP2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -122,7 +120,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERauxiliary +*> \ingroup laqp2 * *> \par Contributors: * ================== @@ -139,13 +137,12 @@ *> *> LAPACK Working Note 176 * -*> \htmlonly *> [PDF] -*> \endhtmlonly * * ===================================================================== SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -164,17 +161,14 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * * .. Parameters .. REAL ZERO, ONE - COMPLEX CONE - PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, - $ CONE = ( 1.0E+0, 0.0E+0 ) ) + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT REAL TEMP, TEMP2, TOL3Z - COMPLEX AII * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, CSWAP + EXTERNAL CLARF1F, CLARFG, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, CONJG, MAX, MIN, SQRT @@ -211,7 +205,8 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN - CALL CLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + CALL CLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), + $ 1, $ TAU( I ) ) ELSE CALL CLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) @@ -221,12 +216,9 @@ SUBROUTINE CLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * * Apply H(i)**H to A(offset+i:m,i+1:n) from the left. * - AII = A( OFFPI, I ) - A( OFFPI, I ) = CONE - CALL CLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, - $ WORK( 1 ) ) - A( OFFPI, I ) = AII + CALL CLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, + $ WORK( 1 ) ) END IF * * Update partial column norms. diff --git a/lapack-netlib/SRC/claqp2rk.f b/lapack-netlib/SRC/claqp2rk.f index 0501c50bb4..d27d978e95 100644 --- a/lapack-netlib/SRC/claqp2rk.f +++ b/lapack-netlib/SRC/claqp2rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAQP2RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -254,7 +252,7 @@ *> \param[out] WORK *> \verbatim *> WORK is COMPLEX array, dimension (N-1) -*> Used in CLARF subroutine to apply an elementary +*> Used in CLARF1F subroutine to apply an elementary *> reflector from the left. *> \endverbatim *> @@ -304,27 +302,19 @@ *> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. *> A BLAS-3 version of the QR factorization with column pivoting. *> LAPACK Working Note 114 -*> \htmlonly *> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf -*> \endhtmlonly *> and in *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. -*> \htmlonly *> https://doi.org/10.1137/S1064827595296732 -*> \endhtmlonly *> *> [2] A partial column norm updating strategy developed in 2006. *> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. *> On the failure of rank revealing QR factorization software – a case study. *> LAPACK Working Note 176. -*> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf -*> \endhtmlonly *> and in *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. -*> \htmlonly *> https://doi.org/10.1145/1377612.1377616 -*> \endhtmlonly * *> \par Contributors: * ================== @@ -364,18 +354,16 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) - COMPLEX CZERO, CONE - PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), - $ CONE = ( 1.0E+0, 0.0E+0 ) ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Local Scalars .. - INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, - $ MINMNUPDT + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, + $ KBOUND, MINMNFACT, MINMNUPDT REAL HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z - COMPLEX AIKK * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFG, CSWAP + EXTERNAL CLARF1F, CLARFG, CSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, REAL, CONJG, AIMAG, MAX, MIN, SQRT @@ -402,13 +390,13 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) - KMAX = MIN( KMAX, MINMNFACT ) + KBOUND = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) HUGEVAL = SLAMCH( 'Overflow' ) * * Compute the factorization, KK is the lomn loop index. * - DO KK = 1, KMAX + DO KK = 1, KBOUND * I = IOFFSET + KK * @@ -633,12 +621,9 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * condition is satisfied, not only KK < N+NRHS ) * IF( KK.LT.MINMNUPDT ) THEN - AIKK = A( I, KK ) - A( I, KK ) = CONE - CALL CLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, - $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA, - $ WORK( 1 ) ) - A( I, KK ) = AIKK + CALL CLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) END IF * IF( KK.LT.MINMNFACT ) THEN @@ -689,7 +674,7 @@ SUBROUTINE CLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * i.e. no condition was triggered to exit the routine. * Set the number of factorized columns. * - K = KMAX + K = KBOUND * * We reached the end of the loop, i.e. all KMAX columns were * factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before diff --git a/lapack-netlib/SRC/claqr2.f b/lapack-netlib/SRC/claqr2.f index 1695fbe5bd..22aa712349 100644 --- a/lapack-netlib/SRC/claqr2.f +++ b/lapack-netlib/SRC/claqr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAQR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -254,7 +252,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERauxiliary +*> \ingroup laqr2 * *> \par Contributors: * ================== @@ -263,9 +261,11 @@ *> University of Kansas, USA *> * ===================================================================== - SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -291,7 +291,7 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. - COMPLEX BETA, CDUM, S, TAU + COMPLEX CDUM, S, TAU REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT @@ -301,8 +301,9 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, EXTERNAL SLAMCH * .. * .. External Subroutines .. - EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLARF, - $ CLARFG, CLASET, CTREXC, CUNMHR, SLABAD + EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, + $ CLARF1F, + $ CLARFG, CLASET, CTREXC, CUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL @@ -329,7 +330,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * * ==== Workspace query call to CUNMHR ==== * - CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, + $ LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * @@ -360,7 +362,6 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN - CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * @@ -399,7 +400,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . here and there to keep track.) ==== * CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) * CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, @@ -451,7 +453,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 20 CONTINUE ILST = I IF( IFST.NE.ILST ) - $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ INFO ) 30 CONTINUE END IF * @@ -471,18 +474,17 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, DO 50 I = 1, NS WORK( I ) = CONJG( WORK( I ) ) 50 CONTINUE - BETA = WORK( 1 ) - CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL CLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * - CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) * - CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL CLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) @@ -500,7 +502,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) - $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, + $ LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== @@ -514,7 +517,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, KLN = MIN( NV, KWTOP-KROW ) CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== @@ -534,7 +538,8 @@ SUBROUTINE CLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) - CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) diff --git a/lapack-netlib/SRC/claqr3.f b/lapack-netlib/SRC/claqr3.f index 2f5402de97..c0f3530c30 100644 --- a/lapack-netlib/SRC/claqr3.f +++ b/lapack-netlib/SRC/claqr3.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CLAQR3 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -251,7 +249,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERauxiliary +*> \ingroup laqr3 * *> \par Contributors: * ================== @@ -260,9 +258,11 @@ *> University of Kansas, USA *> * ===================================================================== - SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, $ NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -288,7 +288,7 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, PARAMETER ( RZERO = 0.0e0, RONE = 1.0e0 ) * .. * .. Local Scalars .. - COMPLEX BETA, CDUM, S, TAU + COMPLEX CDUM, S, TAU REAL FOO, SAFMAX, SAFMIN, SMLNUM, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, @@ -300,8 +300,9 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, EXTERNAL SLAMCH, ILAENV * .. * .. External Subroutines .. - EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, CLAQR4, - $ CLARF, CLARFG, CLASET, CTREXC, CUNMHR, SLABAD + EXTERNAL CCOPY, CGEHRD, CGEMM, CLACPY, CLAHQR, + $ CLAQR4, + $ CLARF1F, CLARFG, CLASET, CTREXC, CUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CMPLX, CONJG, INT, MAX, MIN, REAL @@ -328,13 +329,15 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * * ==== Workspace query call to CUNMHR ==== * - CALL CUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + 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 ==== * - CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, V, + CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, + $ V, $ LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * @@ -365,7 +368,6 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * SAFMIN = SLAMCH( 'SAFE MINIMUM' ) SAFMAX = RONE / SAFMIN - CALL SLABAD( SAFMIN, SAFMAX ) ULP = SLAMCH( 'PRECISION' ) SMLNUM = SAFMIN*( REAL( N ) / ULP ) * @@ -404,15 +406,18 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . here and there to keep track.) ==== * CALL CLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + CALL CCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) * CALL CLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'CLAQR3', 'SV', JW, 1, JW, LWORK ) IF( JW.GT.NMIN ) THEN - CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + CALL CLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), + $ 1, $ JW, V, LDV, WORK, LWORK, INFQR ) ELSE - CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + CALL CLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), + $ 1, $ JW, V, LDV, INFQR ) END IF * @@ -462,7 +467,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, 20 CONTINUE ILST = I IF( IFST.NE.ILST ) - $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + $ CALL CTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ INFO ) 30 CONTINUE END IF * @@ -482,18 +488,17 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, DO 50 I = 1, NS WORK( I ) = CONJG( WORK( I ) ) 50 CONTINUE - BETA = WORK( 1 ) - CALL CLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL CLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * - CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + CALL CLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) * - CALL CLARF( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL CLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL CLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL CLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL CGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) @@ -511,7 +516,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) - $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ CALL CUNMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, + $ LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== @@ -525,7 +531,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, KLN = MIN( NV, KWTOP-KROW ) CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + CALL CLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) 60 CONTINUE * * ==== Update horizontal slab in H ==== @@ -545,7 +552,8 @@ SUBROUTINE CLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IF( WANTZ ) THEN DO 80 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) - CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + CALL CGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL CLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) diff --git a/lapack-netlib/SRC/clarf1f.f b/lapack-netlib/SRC/clarf1f.f new file mode 100644 index 0000000000..cb9fc47ee1 --- /dev/null +++ b/lapack-netlib/SRC/clarf1f.f @@ -0,0 +1,266 @@ +*> \brief \b CLARF1F applies an elementary reflector to a general rectangular +* matrix assuming v(1) = 1. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download CLARF1F + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX TAU +* .. +* .. Array Arguments .. +* COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLARF1F applies a complex elementary reflector H to a complex m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a complex scalar and v is a complex vector assuming v(1) = 1. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +* ===================================================================== + SUBROUTINE CLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX TAU +* .. +* .. Array Arguments .. + COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), + $ ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CGEMV, CGER, CSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILACLR, ILACLC + EXTERNAL LSAME, ILACLR, ILACLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V up to V(1). + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILACLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILACLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.1 ) THEN +* +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* + CALL CSCAL( LASTC, ONE - TAU, C, LDC ) + ELSE +* +* w(1:lastc,1) := C(2:lastv,1:lastc)**H * v(2:lastv,1) +* + CALL CGEMV( 'Conjugate transpose', LASTV - 1, LASTC, ONE, + $ C( 2, 1 ), LDC, V( 1 + INCV ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H +* + DO I = 1, LASTC + WORK( I ) = WORK( I ) + CONJG( C( 1, I ) ) + END DO +* +* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**H +* + DO I = 1, LASTC + C( 1, I ) = C( 1, I ) - TAU * CONJG( WORK( I ) ) + END DO +* +* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H +* + CALL CGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, + $ WORK, 1, C( 2, 1 ), LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.1 ) THEN +* +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* + CALL CSCAL( LASTC, ONE - TAU, C, 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) +* + CALL CGEMV( 'No transpose', LASTC, LASTV - 1, ONE, + $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1:lastc,1) +* + CALL CAXPY( LASTC, ONE, C, 1, WORK, 1 ) +* +* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) +* + CALL CAXPY( LASTC, -TAU, WORK, 1, C, 1 ) +* +* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**H +* + CALL CGERC( LASTC, LASTV - 1, -TAU, WORK, 1, + $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) + END IF + END IF + RETURN +* +* End of CLARF1F +* + END diff --git a/lapack-netlib/SRC/clarf1l.f b/lapack-netlib/SRC/clarf1l.f new file mode 100644 index 0000000000..a592255f16 --- /dev/null +++ b/lapack-netlib/SRC/clarf1l.f @@ -0,0 +1,264 @@ +*> \brief \b CLARF1L applies an elementary reflector to a general rectangular +* matrix assuming v(lastv) = 1, where lastv is the last non-zero +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download CLARF1L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX TAU +* .. +* .. Array Arguments .. +* COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CLARF1L applies a complex elementary reflector H to a complex m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1, +*> where lastv is the last non-zero element. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV > 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +* ===================================================================== + SUBROUTINE CLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX TAU +* .. +* .. Array Arguments .. + COMPLEX C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX ONE, ZERO + PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), + $ ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, J, LASTV, LASTC, FIRSTV +* .. +* .. External Subroutines .. + EXTERNAL CAXPY, CGEMV, CGERC, CSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILACLR, ILACLC + EXTERNAL LSAME, ILACLR, ILACLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + FIRSTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V up to V(1). + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + I = 1 +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO ) + FIRSTV = FIRSTV + 1 + I = I + INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILACLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILACLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) +* + CALL CSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) + ELSE +* +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) +* + CALL CGEMV( 'Conjugate transpose', LASTV - FIRSTV, LASTC, + $ ONE, C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1) +* + DO J = 1, LASTC + WORK( J ) = WORK( J ) + CONJG( C( LASTV, J ) ) + END DO +* +* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H +* + DO J = 1, LASTC + C( LASTV, J ) = C( LASTV, J ) + $ - TAU * CONJG( WORK( J ) ) + END DO +* +* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H +* + CALL CGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) +* + CALL CSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) +* + CALL CGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE, + $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) +* + CALL CAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 ) +* +* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) +* + CALL CAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) +* +* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H +* + CALL CGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) + END IF + END IF + RETURN +* +* End of CLARF1L +* + END diff --git a/lapack-netlib/SRC/cunbdb.f b/lapack-netlib/SRC/cunbdb.f index b45dcfde6f..ee0cb2871e 100644 --- a/lapack-netlib/SRC/cunbdb.f +++ b/lapack-netlib/SRC/cunbdb.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNBDB + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -281,9 +279,11 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, + SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, + $ LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -306,8 +306,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * .. Parameters .. REAL REALONE PARAMETER ( REALONE = 1.0E0 ) - COMPLEX ONE - PARAMETER ( ONE = (1.0E0,0.0E0) ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY @@ -315,7 +313,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, REAL Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. - EXTERNAL CAXPY, CLARF, CLARFGP, CSCAL, XERBLA + EXTERNAL CAXPY, CLARF1F, CLARFGP, CSCAL, + $ XERBLA EXTERNAL CLACGV * * .. @@ -418,11 +417,11 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ SCNRM2( P-I+1, X11(I,I), 1 ) ) * IF( P .GT. I ) THEN - CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, + $ TAUP1(I) ) ELSE IF ( P .EQ. I ) THEN CALL CLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) END IF - X11(I,I) = ONE IF ( M-P .GT. I ) THEN CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) @@ -430,19 +429,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, $ TAUP2(I) ) END IF - X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, - $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK ) - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, - $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, + $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, + $ WORK ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL CLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, - $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) - CALL CLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, - $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + CALL CLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) + CALL CLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN @@ -451,7 +451,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CAXPY( Q-I, CMPLX( Z2*Z3*COS(THETA(I)), 0.0E0 ), $ X21(I,I+1), LDX21, X11(I,I+1), LDX11 ) END IF - CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)), 0.0E0 ), + CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)), + $ 0.0E0 ), $ X12(I,I), LDX12 ) CALL CAXPY( M-Q-I+1, CMPLX( Z2*Z4*COS(THETA(I)), 0.0E0 ), $ X22(I,I), LDX22, X12(I,I), LDX12 ) @@ -469,7 +470,6 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, $ TAUQ1(I) ) END IF - X11(I,I+1) = ONE END IF IF ( M-Q+1 .GT. I ) THEN CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) @@ -481,21 +481,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ TAUQ2(I) ) END IF END IF - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL CLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) - CALL CLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL CLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), X11(I+1,I+1), LDX11, WORK ) + CALL CLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN - CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN - CALL CLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + CALL CLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) END IF * IF( I .LT. Q ) @@ -518,15 +517,14 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, $ TAUQ2(I) ) END IF - X12(I,I) = ONE * IF ( P .GT. I ) THEN - CALL CLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL CLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL CLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) + $ CALL CLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) * CALL CLACGV( M-Q-I+1, X12(I,I), LDX12 ) * @@ -541,9 +539,9 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) CALL CLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), $ LDX22, TAUQ2(P+I) ) - X22(Q+I,P+I) = ONE - CALL CLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + CALL CLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, + $ WORK ) * CALL CLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) * @@ -580,8 +578,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CLACGV( P-I+1, X11(I,I), LDX11 ) CALL CLACGV( M-P-I+1, X21(I,I), LDX21 ) * - CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) - X11(I,I) = ONE + CALL CLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, + $ TAUP1(I) ) IF ( I .EQ. M-P ) THEN CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, $ TAUP2(I) ) @@ -589,16 +587,15 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, $ TAUP2(I) ) END IF - X21(I,I) = ONE * - CALL CLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) - CALL CLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X12(I,I), LDX12, WORK ) - CALL CLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) - CALL CLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), X22(I,I), LDX22, WORK ) + CALL CLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + CALL CLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) + CALL CLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X21(I+1,I), LDX21, WORK ) + CALL CLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) * CALL CLACGV( P-I+1, X11(I,I), LDX11 ) CALL CLACGV( M-P-I+1, X21(I,I), LDX21 ) @@ -609,7 +606,8 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL CAXPY( Q-I, CMPLX( Z2*Z3*COS(THETA(I)), 0.0E0 ), $ X21(I+1,I), 1, X11(I+1,I), 1 ) END IF - CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)), 0.0E0 ), + CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4*SIN(THETA(I)), + $ 0.0E0 ), $ X12(I,I), 1 ) CALL CAXPY( M-Q-I+1, CMPLX( Z2*Z4*COS(THETA(I)), 0.0E0 ), $ X22(I,I), 1, X12(I,I), 1 ) @@ -619,24 +617,27 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ SCNRM2( M-Q-I+1, X12(I,I), 1 ) ) * IF( I .LT. Q ) THEN - CALL CLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) ) - X11(I+1,I) = ONE + CALL CLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, + $ TAUQ1(I) ) END IF - CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) - X12(I,I) = ONE + CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) * IF( I .LT. Q ) THEN - CALL CLARF( 'L', Q-I, P-I, X11(I+1,I), 1, - $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, WORK ) - CALL CLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, - $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, WORK ) + CALL CLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, + $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, + $ WORK ) + CALL CLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, + $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, + $ WORK ) END IF - CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, CONJG(TAUQ2(I)), - $ X12(I,I+1), LDX12, WORK ) + CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) IF ( M-P .GT. I ) THEN - CALL CLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK ) + CALL CLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, + $ WORK ) END IF END DO * @@ -644,17 +645,20 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * DO I = Q + 1, P * - CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I), 1 ) - CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) - X12(I,I) = ONE + CALL CSCAL( M-Q-I+1, CMPLX( -Z1*Z4, 0.0E0 ), X12(I,I), + $ 1 ) + CALL CLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) * IF ( P .GT. I ) THEN - CALL CLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK ) + CALL CLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, + $ WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL CLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, - $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK ) + $ CALL CLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, + $ WORK ) * END DO * @@ -666,11 +670,10 @@ SUBROUTINE CUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ X22(P+I,Q+I), 1 ) CALL CLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE IF ( M-P-Q .NE. I ) THEN - CALL CLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22, - $ WORK ) + CALL CLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), + $ 1, CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), + $ LDX22, WORK ) END IF END DO * diff --git a/lapack-netlib/SRC/cunbdb1.f b/lapack-netlib/SRC/cunbdb1.f index a4875ab5ba..08b2fd8465 100644 --- a/lapack-netlib/SRC/cunbdb1.f +++ b/lapack-netlib/SRC/cunbdb1.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNBDB1 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -197,8 +195,10 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -215,10 +215,6 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * * ==================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = (1.0E0,0.0E0) ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -226,7 +222,8 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, + $ XERBLA EXTERNAL CLACGV * .. * .. External Functions .. @@ -285,24 +282,24 @@ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I) = ONE - X21(I,I) = ONE - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK(ILARF) ) - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) * IF( I .LT. Q ) THEN CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, $ S ) CALL CLACGV( Q-I, X21(I,I+1), LDX21 ) - CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, + $ TAUQ1(I) ) S = REAL( X21(I,I+1) ) - X21(I,I+1) = ONE - CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, + $ TAUQ1(I), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) CALL CLACGV( Q-I, X21(I,I+1), LDX21 ) C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1 )**2 $ + SCNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) diff --git a/lapack-netlib/SRC/cunbdb2.f b/lapack-netlib/SRC/cunbdb2.f index 6399964f8d..337e572a0d 100644 --- a/lapack-netlib/SRC/cunbdb2.f +++ b/lapack-netlib/SRC/cunbdb2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNBDB2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -197,8 +195,10 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -216,9 +216,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * ==================================================================== * * .. Parameters .. - COMPLEX NEGONE, ONE - PARAMETER ( NEGONE = (-1.0E0,0.0E0), - $ ONE = (1.0E0,0.0E0) ) + COMPLEX NEGONE + PARAMETER ( NEGONE = (-1.0E0,0.0E0) ) * .. * .. Local Scalars .. REAL C, S @@ -227,7 +226,8 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, CLACGV, + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CSCAL, + $ CLACGV, $ XERBLA * .. * .. External Functions .. @@ -288,11 +288,10 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) C = REAL( X11(I,I) ) - X11(I,I) = ONE - CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, + $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2 $ + SCNRM2( M-P-I+1, X21(I,I), 1 )**2 ) @@ -308,13 +307,13 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X11(I+1,I) = ONE - CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, CONJG(TAUP1(I)), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, + $ CONJG(TAUP1(I)), X11(I+1,I+1), LDX11, + $ WORK(ILARF) ) END IF - X21(I,I) = ONE - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) * END DO * @@ -322,9 +321,9 @@ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * DO I = P + 1, Q CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) - X21(I,I) = ONE - CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) END DO * RETURN diff --git a/lapack-netlib/SRC/cunbdb3.f b/lapack-netlib/SRC/cunbdb3.f index d024605979..c03de68257 100644 --- a/lapack-netlib/SRC/cunbdb3.f +++ b/lapack-netlib/SRC/cunbdb3.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNBDB3 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -197,8 +195,10 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -215,10 +215,6 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * * ==================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = (1.0E0,0.0E0) ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -226,7 +222,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CLACGV, XERBLA + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CLACGV, + $ XERBLA * .. * .. External Functions .. REAL SCNRM2, SROUNDUP_LWORK @@ -287,11 +284,10 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) S = REAL( X21(I,I) ) - X21(I,I) = ONE - CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) C = SQRT( SCNRM2( P-I+1, X11(I,I), 1 )**2 $ + SCNRM2( M-P-I, X21(I+1,I), 1 )**2 ) @@ -302,17 +298,17 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ WORK(IORBDB5), LORBDB5, CHILDINFO ) CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) IF( I .LT. M-P ) THEN - CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, + $ TAUP2(I) ) PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X21(I+1,I) = ONE - CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, CONJG(TAUP2(I)), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, + $ CONJG(TAUP2(I)), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) END IF - X11(I,I) = ONE - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) * END DO * @@ -320,9 +316,8 @@ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * DO I = M-P + 1, Q CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) - X11(I,I) = ONE - CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), - $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) END DO * RETURN diff --git a/lapack-netlib/SRC/cunbdb4.f b/lapack-netlib/SRC/cunbdb4.f index 33acc1ee51..16e71860c1 100644 --- a/lapack-netlib/SRC/cunbdb4.f +++ b/lapack-netlib/SRC/cunbdb4.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNBDB4 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -207,9 +205,11 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -227,8 +227,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * ==================================================================== * * .. Parameters .. - COMPLEX NEGONE, ONE, ZERO - PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0), + COMPLEX NEGONE, ZERO + PARAMETER ( NEGONE = (-1.0E0,0.0E0), $ ZERO = (0.0E0,0.0E0) ) * .. * .. Local Scalars .. @@ -238,7 +238,8 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, CLACGV, + EXTERNAL CLARF1F, CLARFGP, CUNBDB5, CSROT, CSCAL, + $ CLACGV, $ XERBLA * .. * .. External Functions .. @@ -302,44 +303,43 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ LORBDB5, CHILDINFO ) CALL CSCAL( P, NEGONE, PHANTOM(1), 1 ) CALL CLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) - CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, + $ TAUP2(1) ) THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - PHANTOM(1) = ONE - PHANTOM(P+1) = ONE - CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), X11, - $ LDX11, WORK(ILARF) ) - CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, CONJG(TAUP2(1)), - $ X21, LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), + $ X11, LDX11, WORK(ILARF) ) + CALL CLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, + $ CONJG(TAUP2(1)), X21, LDX21, WORK(ILARF) ) ELSE CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) CALL CSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) - CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, + $ TAUP1(I) ) CALL CLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, $ TAUP2(I) ) THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I-1) = ONE - X21(I,I-1) = ONE - CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, - $ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, - $ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, + $ CONJG(TAUP1(I)), X11(I,I), LDX11, + $ WORK(ILARF) ) + CALL CLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ CONJG(TAUP2(I)), X21(I,I), LDX21, + $ WORK(ILARF) ) END IF * CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) C = REAL( X21(I,I) ) - X21(I,I) = ONE - CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(I,I), LDX21 ) IF( I .LT. M-Q ) THEN S = SQRT( SCNRM2( P-I, X11(I+1,I), 1 )**2 @@ -354,11 +354,10 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, DO I = M - Q + 1, P CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) - X11(I,I) = ONE - CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL CLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) CALL CLACGV( Q-I+1, X11(I,I), LDX11 ) END DO * @@ -366,11 +365,12 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * DO I = P + 1, Q CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) - CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), + $ LDX21, $ TAUQ1(I) ) - X21(M-Q+I-P,I) = ONE - CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), - $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL CLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, + $ TAUQ1(I), X21(M-Q+I-P+1,I), LDX21, + $ WORK(ILARF) ) CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) END DO * diff --git a/lapack-netlib/SRC/cung2l.f b/lapack-netlib/SRC/cung2l.f index a05843a5d3..477876cc5c 100644 --- a/lapack-netlib/SRC/cung2l.f +++ b/lapack-netlib/SRC/cung2l.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNG2L + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,10 +105,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup ung2l * * ===================================================================== SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,7 +133,7 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL CLARF, CSCAL, XERBLA + EXTERNAL CLARF1L, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -178,8 +177,8 @@ SUBROUTINE CUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE - CALL CLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) + CALL CLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), + $ A, LDA, WORK ) CALL CSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * diff --git a/lapack-netlib/SRC/cung2r.f b/lapack-netlib/SRC/cung2r.f index a984818c1e..d48e050aa9 100644 --- a/lapack-netlib/SRC/cung2r.f +++ b/lapack-netlib/SRC/cung2r.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNG2R + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,10 +105,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup ung2r * * ===================================================================== SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,7 +133,7 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL CLARF, CSCAL, XERBLA + EXTERNAL CLARF1F, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -177,9 +176,8 @@ SUBROUTINE CUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL CLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) + CALL CLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL CSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) diff --git a/lapack-netlib/SRC/cungl2.f b/lapack-netlib/SRC/cungl2.f index 81a3b89cd8..8b5b2b8457 100644 --- a/lapack-netlib/SRC/cungl2.f +++ b/lapack-netlib/SRC/cungl2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNGL2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -106,10 +104,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup ungl2 * * ===================================================================== SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -133,7 +132,7 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CSCAL, XERBLA + EXTERNAL CLACGV, CLARF1F, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -182,9 +181,9 @@ SUBROUTINE CUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) IF( I.LT.N ) THEN CALL CLACGV( N-I, A( I, I+1 ), LDA ) IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL CLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ CONJG( TAU( I ) ), A( I+1, I ), LDA, WORK ) + CALL CLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ CONJG( TAU( I ) ), A( I+1, I ), LDA, + $ WORK ) END IF CALL CSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) CALL CLACGV( N-I, A( I, I+1 ), LDA ) diff --git a/lapack-netlib/SRC/cungr2.f b/lapack-netlib/SRC/cungr2.f index 1f2f2b4610..e421117f02 100644 --- a/lapack-netlib/SRC/cungr2.f +++ b/lapack-netlib/SRC/cungr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNGR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,10 +105,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup ungr2 * * ===================================================================== SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,7 +133,7 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, CSCAL, XERBLA + EXTERNAL CLACGV, CLARF1L, CSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -183,8 +182,8 @@ SUBROUTINE CUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * CALL CLACGV( N-M+II-1, A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - CALL CLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, - $ CONJG( TAU( I ) ), A, LDA, WORK ) + CALL CLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA, + $ CONJG( TAU( I ) ), A, LDA, WORK ) CALL CSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) CALL CLACGV( N-M+II-1, A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - CONJG( TAU( I ) ) diff --git a/lapack-netlib/SRC/cunm2l.f b/lapack-netlib/SRC/cunm2l.f index 416c0a0c36..0b6ffc8ca0 100644 --- a/lapack-netlib/SRC/cunm2l.f +++ b/lapack-netlib/SRC/cunm2l.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNM2L + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup unm2l * * ===================================================================== SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,17 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLARF, XERBLA + EXTERNAL CLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -266,10 +261,8 @@ SUBROUTINE CUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL CLARF( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, WORK ) - A( NQ-K+I, I ) = AII + CALL CLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, + $ WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/cunm2r.f b/lapack-netlib/SRC/cunm2r.f index a79e9a78d0..c357356235 100644 --- a/lapack-netlib/SRC/cunm2r.f +++ b/lapack-netlib/SRC/cunm2r.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNM2R + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup unm2r * * ===================================================================== SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,17 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLARF, XERBLA + EXTERNAL CLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -270,11 +265,8 @@ SUBROUTINE CUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, ELSE TAUI = CONJG( TAU( I ) ) END IF - AII = A( I, I ) - A( I, I ) = ONE - CALL CLARF( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), LDC, - $ WORK ) - A( I, I ) = AII + CALL CLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), + $ LDC, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/cunmr2.f b/lapack-netlib/SRC/cunmr2.f index ebd4cfbb64..ca4f9fd6f8 100644 --- a/lapack-netlib/SRC/cunmr2.f +++ b/lapack-netlib/SRC/cunmr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUNMR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup unmr2 * * ===================================================================== SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,17 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLACGV, CLARF, XERBLA + EXTERNAL CLACGV, CLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -267,10 +262,8 @@ SUBROUTINE CUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, TAUI = TAU( I ) END IF CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA ) - AII = A( I, NQ-K+I ) - A( I, NQ-K+I ) = ONE - CALL CLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, WORK ) - A( I, NQ-K+I ) = AII + CALL CLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, + $ WORK ) CALL CLACGV( NQ-K+I-1, A( I, 1 ), LDA ) 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/cupmtr.f b/lapack-netlib/SRC/cupmtr.f index 2629e91792..b4fb38e854 100644 --- a/lapack-netlib/SRC/cupmtr.f +++ b/lapack-netlib/SRC/cupmtr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CUPMTR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -142,11 +140,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup upmtr * * ===================================================================== - SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, + SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, + $ WORK, $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -162,21 +162,17 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * * ===================================================================== * -* .. Parameters .. - COMPLEX ONE - PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) -* .. * .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ - COMPLEX AII, TAUI + COMPLEX TAUI * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL CLARF, XERBLA + EXTERNAL CLARF1F, CLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC CONJG, MAX @@ -265,11 +261,8 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, ELSE TAUI = CONJG( TAU( I ) ) END IF - AII = AP( II ) - AP( II ) = ONE - CALL CLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, LDC, - $ WORK ) - AP( II ) = AII + CALL CLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, + $ LDC, WORK ) * IF( FORWRD ) THEN II = II + I + 2 @@ -305,8 +298,6 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, END IF * DO 20 I = I1, I2, I3 - AII = AP( II ) - AP( II ) = ONE IF( LEFT ) THEN * * H(i) or H(i)**H is applied to C(i+1:m,1:n) @@ -328,9 +319,8 @@ SUBROUTINE CUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, ELSE TAUI = CONJG( TAU( I ) ) END IF - CALL CLARF( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, JC ), - $ LDC, WORK ) - AP( II ) = AII + CALL CLARF1F( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, + $ JC ), LDC, WORK ) * IF( FORWRD ) THEN II = II + NQ - I + 1 diff --git a/lapack-netlib/SRC/sgebd2.f b/lapack-netlib/SRC/sgebd2.f index cb57ed6780..b49421b261 100644 --- a/lapack-netlib/SRC/sgebd2.f +++ b/lapack-netlib/SRC/sgebd2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGEBD2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -132,7 +130,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup gebd2 * *> \par Further Details: * ===================== @@ -186,6 +184,7 @@ *> * ===================================================================== SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -209,7 +208,7 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) INTEGER I * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -242,14 +241,12 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, $ TAUQ( I ) ) D( I ) = A( I, I ) - A( I, I ) = ONE * * Apply H(i) to A(i:m,i+1:n) from the left * IF( I.LT.N ) - $ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) + $ CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAUQ( I ), A( I, I+1 ), LDA, WORK ) * IF( I.LT.N ) THEN * @@ -259,13 +256,11 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), $ LDA, TAUP( I ) ) E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE * * Apply G(i) to A(i+1:m,i+1:n) from the right * - CALL SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) + CALL SLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) ELSE TAUP( I ) = ZERO END IF @@ -278,33 +273,31 @@ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) * * Generate elementary reflector G(i) to annihilate A(i,i+1:n) * - CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, + CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), + $ LDA, $ TAUP( I ) ) D( I ) = A( I, I ) - A( I, I ) = ONE * * Apply G(i) to A(i+1:m,i:n) from the right * IF( I.LT.M ) - $ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAUP( I ), A( I+1, I ), LDA, WORK ) - A( I, I ) = D( I ) + $ CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) * IF( I.LT.M ) THEN * * Generate elementary reflector H(i) to annihilate * A(i+2:m,i) * - CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, + CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), + $ 1, $ TAUQ( I ) ) E( I ) = A( I+1, I ) - A( I+1, I ) = ONE * * Apply H(i) to A(i+1:m,i+1:n) from the left * - CALL SLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) + CALL SLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, + $ TAUQ( I ), A( I+1, I+1 ), LDA, WORK ) ELSE TAUQ( I ) = ZERO END IF diff --git a/lapack-netlib/SRC/sgehd2.f b/lapack-netlib/SRC/sgehd2.f index c7d8db19ec..bd3ff718b2 100644 --- a/lapack-netlib/SRC/sgehd2.f +++ b/lapack-netlib/SRC/sgehd2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGEHD2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -106,7 +104,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup gehd2 * *> \par Further Details: * ===================== @@ -146,6 +144,7 @@ *> * ===================================================================== SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -160,16 +159,11 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -199,20 +193,17 @@ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) * CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, $ TAU( I ) ) - AII = A( I+1, I ) - A( I+1, I ) = ONE * * Apply H(i) to A(1:ihi,i+1:ihi) from the right * - CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), - $ A( 1, I+1 ), LDA, WORK ) + CALL SLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) * * Apply H(i) to A(i+1:ihi,i+1:n) from the left * - CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), - $ A( I+1, I+1 ), LDA, WORK ) + CALL SLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), + $ A( I+1, I+1 ), LDA, WORK ) * - A( I+1, I ) = AII 10 CONTINUE * RETURN diff --git a/lapack-netlib/SRC/sgelq2.f b/lapack-netlib/SRC/sgelq2.f index 3e50beb13e..f0562432bf 100644 --- a/lapack-netlib/SRC/sgelq2.f +++ b/lapack-netlib/SRC/sgelq2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGELQ2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -104,7 +102,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup gelq2 * *> \par Further Details: * ===================== @@ -126,6 +124,7 @@ *> * ===================================================================== SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -140,16 +139,11 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -183,11 +177,8 @@ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(i+1:m,i:n) from the right * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII + CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/sgeql2.f b/lapack-netlib/SRC/sgeql2.f index ea5ad6b82d..99d9f49ed4 100644 --- a/lapack-netlib/SRC/sgeql2.f +++ b/lapack-netlib/SRC/sgeql2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGEQL2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -98,7 +96,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup geql2 * *> \par Further Details: * ===================== @@ -120,6 +118,7 @@ *> * ===================================================================== SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,16 +133,11 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1L, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -177,11 +171,8 @@ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left * - AII = A( M-K+I, N-K+I ) - A( M-K+I, N-K+I ) = ONE - CALL SLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ), - $ A, LDA, WORK ) - A( M-K+I, N-K+I ) = AII + CALL SLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, + $ TAU( I ), A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/sgeqp3rk.f b/lapack-netlib/SRC/sgeqp3rk.f index d3a335b88e..9f0b76328d 100644 --- a/lapack-netlib/SRC/sgeqp3rk.f +++ b/lapack-netlib/SRC/sgeqp3rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGEQP3RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -546,27 +544,19 @@ *> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. *> A BLAS-3 version of the QR factorization with column pivoting. *> LAPACK Working Note 114 -*> \htmlonly *> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf -*> \endhtmlonly *> and in *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. -*> \htmlonly *> https://doi.org/10.1137/S1064827595296732 -*> \endhtmlonly *> *> [2] A partial column norm updating strategy developed in 2006. *> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. *> On the failure of rank revealing QR factorization software – a case study. *> LAPACK Working Note 176. -*> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf -*> \endhtmlonly *> and in *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. -*> \htmlonly *> https://doi.org/10.1145/1377612.1377616 -*> \endhtmlonly * *> \par Contributors: * ================== @@ -671,7 +661,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 1) SGEQP3RK and SLAQP2RK: 2*N to store full and partial * column 2-norms. * 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used -* in SLARF subroutine inside SLAQP2RK to apply an +* in SLARF1F subroutine inside SLAQP2RK to apply an * elementary reflector from the left. * TOTAL_WORK_SIZE = 3*N + NRHS - 1 * @@ -687,7 +677,7 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * 1) SGEQP3RK, SLAQP2RK, SLAQP3RK: 2*N to store full and * partial column 2-norms. * 2) SLAQP2RK: N+NRHS-1 to use in WORK array that is used -* in SLARF subroutine to apply an elementary reflector +* in SLARF1F subroutine to apply an elementary reflector * from the left. * 3) SLAQP3RK: NB*(N+NRHS) to use in the work array F that * is used to apply a block reflector from @@ -887,7 +877,8 @@ SUBROUTINE SGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, * Determine when to cross over from blocked to unblocked code. * (for N less than NX, unblocked code should be used). * - NX = MAX( 0, ILAENV( IXOVER, 'SGEQP3RK', ' ', M, N, -1, -1 )) + NX = MAX( 0, ILAENV( IXOVER, 'SGEQP3RK', ' ', M, N, -1, + $ -1 )) * IF( NX.LT.MINMN ) THEN * diff --git a/lapack-netlib/SRC/sgeqr2.f b/lapack-netlib/SRC/sgeqr2.f index 5eef521f27..0a9c3936df 100644 --- a/lapack-netlib/SRC/sgeqr2.f +++ b/lapack-netlib/SRC/sgeqr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGEQR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -105,7 +103,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup geqr2 * *> \par Further Details: * ===================== @@ -127,6 +125,7 @@ *> * ===================================================================== SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -141,16 +140,11 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1F, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -184,11 +178,8 @@ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(i:m,i+1:n) from the left * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII + CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/sgeqr2p.f b/lapack-netlib/SRC/sgeqr2p.f index 0d270e9aa8..1e8c1f3e43 100644 --- a/lapack-netlib/SRC/sgeqr2p.f +++ b/lapack-netlib/SRC/sgeqr2p.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGEQR2P + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,7 +105,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup geqr2p * *> \par Further Details: * ===================== @@ -131,6 +129,7 @@ *> * ===================================================================== SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -145,16 +144,11 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, XERBLA + EXTERNAL SLARF1F, SLARFGP, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -188,11 +182,8 @@ SUBROUTINE SGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(i:m,i+1:n) from the left * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII + CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF 10 CONTINUE RETURN diff --git a/lapack-netlib/SRC/sgerq2.f b/lapack-netlib/SRC/sgerq2.f index d86905c033..14c8cf0517 100644 --- a/lapack-netlib/SRC/sgerq2.f +++ b/lapack-netlib/SRC/sgerq2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SGERQ2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -98,7 +96,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realGEcomputational +*> \ingroup gerq2 * *> \par Further Details: * ===================== @@ -120,6 +118,7 @@ *> * ===================================================================== SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -134,16 +133,11 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. INTEGER I, K - REAL AII * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, XERBLA + EXTERNAL SLARF1L, SLARFG, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN @@ -177,11 +171,8 @@ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO ) * * Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right * - AII = A( M-K+I, N-K+I ) - A( M-K+I, N-K+I ) = ONE - CALL SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, - $ TAU( I ), A, LDA, WORK ) - A( M-K+I, N-K+I ) = AII + CALL SLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/slaqp2.f b/lapack-netlib/SRC/slaqp2.f index 595fb8c340..530d1913d6 100644 --- a/lapack-netlib/SRC/slaqp2.f +++ b/lapack-netlib/SRC/slaqp2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLAQP2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -122,7 +120,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERauxiliary +*> \ingroup laqp2 * *> \par Contributors: * ================== @@ -139,13 +137,12 @@ *> *> LAPACK Working Note 176 * -*> \htmlonly *> [PDF] -*> \endhtmlonly * * ===================================================================== SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, $ WORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -168,10 +165,10 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * .. * .. Local Scalars .. INTEGER I, ITEMP, J, MN, OFFPI, PVT - REAL AII, TEMP, TEMP2, TOL3Z + REAL TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, SSWAP + EXTERNAL SLARF1F, SLARFG, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -208,7 +205,8 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * Generate elementary reflector H(i). * IF( OFFPI.LT.M ) THEN - CALL SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1, + CALL SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), + $ 1, $ TAU( I ) ) ELSE CALL SLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) @@ -218,11 +216,8 @@ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, * * Apply H(i)**T to A(offset+i:m,i+1:n) from the left. * - AII = A( OFFPI, I ) - A( OFFPI, I ) = ONE - CALL SLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, - $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) - A( OFFPI, I ) = AII + CALL SLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) END IF * * Update partial column norms. diff --git a/lapack-netlib/SRC/slaqp2rk.f b/lapack-netlib/SRC/slaqp2rk.f index f88b0ce909..3825e25106 100644 --- a/lapack-netlib/SRC/slaqp2rk.f +++ b/lapack-netlib/SRC/slaqp2rk.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLAQP2RK + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -253,7 +251,7 @@ *> \param[out] WORK *> \verbatim *> WORK is REAL array, dimension (N-1) -*> Used in SLARF subroutine to apply an elementary +*> Used in SLARF1F subroutine to apply an elementary *> reflector from the left. *> \endverbatim *> @@ -303,27 +301,19 @@ *> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. *> A BLAS-3 version of the QR factorization with column pivoting. *> LAPACK Working Note 114 -*> \htmlonly *> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf -*> \endhtmlonly *> and in *> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. -*> \htmlonly *> https://doi.org/10.1137/S1064827595296732 -*> \endhtmlonly *> *> [2] A partial column norm updating strategy developed in 2006. *> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. *> On the failure of rank revealing QR factorization software – a case study. *> LAPACK Working Note 176. -*> \htmlonly *> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf -*> \endhtmlonly *> and in *> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. -*> \htmlonly *> https://doi.org/10.1145/1377612.1377616 -*> \endhtmlonly * *> \par Contributors: * ================== @@ -365,12 +355,12 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. * .. Local Scalars .. - INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, MINMNFACT, - $ MINMNUPDT - REAL AIKK, HUGEVAL, TEMP, TEMP2, TOL3Z + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, + $ KBOUND, MINMNFACT, MINMNUPDT + REAL HUGEVAL, TEMP, TEMP2, TOL3Z * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFG, SSWAP + EXTERNAL SLARF1F, SLARFG, SSWAP * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT @@ -397,13 +387,13 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * MINMNFACT = MIN( M-IOFFSET, N ) MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) - KMAX = MIN( KMAX, MINMNFACT ) + KBOUND = MIN( KMAX, MINMNFACT ) TOL3Z = SQRT( SLAMCH( 'Epsilon' ) ) HUGEVAL = SLAMCH( 'Overflow' ) * * Compute the factorization, KK is the lomn loop index. * - DO KK = 1, KMAX + DO KK = 1, KBOUND * I = IOFFSET + KK * @@ -621,11 +611,8 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * condition is satisfied, not only KK < N+NRHS ) * IF( KK.LT.MINMNUPDT ) THEN - AIKK = A( I, KK ) - A( I, KK ) = ONE - CALL SLARF( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, - $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) - A( I, KK ) = AIKK + CALL SLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) END IF * IF( KK.LT.MINMNFACT ) THEN @@ -676,7 +663,7 @@ SUBROUTINE SLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, * i.e. no condition was triggered to exit the routine. * Set the number of factorized columns. * - K = KMAX + K = KBOUND * * We reached the end of the loop, i.e. all KMAX columns were * factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before diff --git a/lapack-netlib/SRC/slaqr2.f b/lapack-netlib/SRC/slaqr2.f index caf79fd1c0..9ee1f8b6e2 100644 --- a/lapack-netlib/SRC/slaqr2.f +++ b/lapack-netlib/SRC/slaqr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLAQR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -272,9 +270,11 @@ *> University of Kansas, USA *> * ===================================================================== - SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -297,7 +297,7 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. - REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + REAL AA, BB, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, @@ -309,8 +309,10 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, EXTERNAL SLAMCH, SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR, - $ SLANV2, SLARF, SLARFG, SLASET, SORMHR, STREXC + EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, + $ SLAHQR, + $ SLANV2, SLARF1L, SLARFG, SLASET, SORMHR, + $ STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT @@ -331,7 +333,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * * ==== Workspace query call to SORMHR ==== * - CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, + $ LDV, $ WORK, -1, INFO ) LWK2 = INT( WORK( 1 ) ) * @@ -401,7 +404,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . here and there to keep track.) ==== * CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) * CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), @@ -448,7 +452,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . (STREXC can not fail in this case.) ==== * IFST = NS - CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, $ INFO ) ILST = ILST + 1 END IF @@ -473,7 +478,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . ILST in case of a rare exchange failure. ==== * IFST = NS - CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, $ INFO ) ILST = ILST + 2 END IF @@ -535,7 +541,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, SORTED = .false. IFST = I ILST = K - CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST @@ -588,18 +595,17 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * ==== Reflect spike back into lower triangle ==== * CALL SCOPY( NS, V, LDV, WORK, 1 ) - BETA = WORK( 1 ) - CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL SLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * - CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) * - CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL SLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) @@ -617,7 +623,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) - $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, + $ LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== @@ -631,7 +638,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, KLN = MIN( NV, KWTOP-KROW ) CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== @@ -651,7 +659,8 @@ SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) - CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) diff --git a/lapack-netlib/SRC/slaqr3.f b/lapack-netlib/SRC/slaqr3.f index d3ffb0f969..f9f8090a3a 100644 --- a/lapack-netlib/SRC/slaqr3.f +++ b/lapack-netlib/SRC/slaqr3.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SLAQR3 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -269,9 +267,11 @@ *> University of Kansas, USA *> * ===================================================================== - SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, + SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, $ LDT, NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE * * -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -294,7 +294,7 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 ) * .. * .. Local Scalars .. - REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + REAL AA, BB, CC, CS, DD, EVI, EVK, FOO, S, $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, @@ -307,8 +307,10 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, EXTERNAL SLAMCH, SROUNDUP_LWORK, ILAENV * .. * .. External Subroutines .. - EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR, SLANV2, - $ SLAQR4, SLARF, SLARFG, SLASET, SORMHR, STREXC + EXTERNAL SCOPY, SGEHRD, SGEMM, SLACPY, SLAHQR, + $ SLANV2, + $ SLAQR4, SLARF1F, SLARFG, SLASET, SORMHR, + $ STREXC * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT @@ -329,13 +331,15 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * * ==== Workspace query call to SORMHR ==== * - CALL SORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, LDV, + 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 ==== * - CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW, + CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, + $ JW, $ V, LDV, WORK, -1, INFQR ) LWK3 = INT( WORK( 1 ) ) * @@ -405,7 +409,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . here and there to keep track.) ==== * CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) - CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 ) + CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) * CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) NMIN = ILAENV( 12, 'SLAQR3', 'SV', JW, 1, JW, LWORK ) @@ -458,7 +463,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . (STREXC can not fail in this case.) ==== * IFST = NS - CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, $ INFO ) ILST = ILST + 1 END IF @@ -483,7 +489,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . ILST in case of a rare exchange failure. ==== * IFST = NS - CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, $ INFO ) ILST = ILST + 2 END IF @@ -545,7 +552,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, SORTED = .false. IFST = I ILST = K - CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK, + CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, $ INFO ) IF( INFO.EQ.0 ) THEN I = ILST @@ -598,18 +606,17 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * ==== Reflect spike back into lower triangle ==== * CALL SCOPY( NS, V, LDV, WORK, 1 ) - BETA = WORK( 1 ) - CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU ) - WORK( 1 ) = ONE + CALL SLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) * - CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT ) + CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) * - CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT, - $ WORK( JW+1 ) ) - CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV, - $ WORK( JW+1 ) ) + CALL SLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL SLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) * CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), $ LWORK-JW, INFO ) @@ -627,7 +634,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, * . H and Z, if requested. ==== * IF( NS.GT.1 .AND. S.NE.ZERO ) - $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, LDV, + $ CALL SORMHR( 'R', 'N', JW, NS, 1, NS, T, LDT, WORK, V, + $ LDV, $ WORK( JW+1 ), LWORK-JW, INFO ) * * ==== Update vertical slab in H ==== @@ -641,7 +649,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, KLN = MIN( NV, KWTOP-KROW ) CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), $ LDH, V, LDV, ZERO, WV, LDWV ) - CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH ) + CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) 70 CONTINUE * * ==== Update horizontal slab in H ==== @@ -661,7 +670,8 @@ SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, IF( WANTZ ) THEN DO 90 KROW = ILOZ, IHIZ, NV KLN = MIN( NV, IHIZ-KROW+1 ) - CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ), + CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), $ LDZ, V, LDV, ZERO, WV, LDWV ) CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), $ LDZ ) diff --git a/lapack-netlib/SRC/slarf1f.f b/lapack-netlib/SRC/slarf1f.f new file mode 100644 index 0000000000..d0c015eacf --- /dev/null +++ b/lapack-netlib/SRC/slarf1f.f @@ -0,0 +1,254 @@ +*> \brief \b SLARF1F applies an elementary reflector to a general rectangular +* matrix assuming v(1) = 1. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download SLARF1F + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* REAL TAU +* .. +* .. Array Arguments .. +* REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLARF1F applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector assuming v(1) = 1. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is REAL +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +* ===================================================================== + SUBROUTINE SLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + REAL TAU +* .. +* .. Array Arguments .. + REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SAXPY, SSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILASLR, ILASLC + EXTERNAL LSAME, ILASLR, ILASLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V up to V(1). + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILASLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILASLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.1 ) THEN +* +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* + CALL SSCAL( LASTC, ONE - TAU, C, LDC ) + ELSE +* +* w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) +* + CALL SGEMV( 'Transpose', LASTV - 1, LASTC, ONE, C( 2, 1 ), + $ LDC, V( 1 + INCV ), INCV, ZERO, WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**T +* + CALL SAXPY( LASTC, ONE, C, LDC, WORK, 1 ) +* +* C(1, 1:lastc) += - tau * v(1,1) * w(1:lastc,1)**T +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C, LDC ) +* +* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**T +* + CALL SGER( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), INCV, + $ WORK, 1, C( 2, 1 ), LDC ) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.1 ) THEN +* +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* + CALL SSCAL( LASTC, ONE - TAU, C, 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) +* + CALL SGEMV( 'No transpose', LASTC, LASTV - 1, ONE, + $ C( 1, 2 ), LDC, V( 1 + INCV ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1:lastc,1) +* + CALL SAXPY( LASTC, ONE, C, 1, WORK, 1 ) +* +* C(1:lastc,1) += - tau * v(1,1) * w(1:lastc,1) +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C, 1 ) +* +* C(1:lastc,2:lastv) += - tau * w(1:lastc,1) * v(2:lastv)**T +* + CALL SGER( LASTC, LASTV - 1, -TAU, WORK, 1, + $ V( 1 + INCV ), INCV, C( 1, 2 ), LDC ) + END IF + END IF + RETURN +* +* End of SLARF1F +* + END diff --git a/lapack-netlib/SRC/slarf1l.f b/lapack-netlib/SRC/slarf1l.f new file mode 100644 index 0000000000..d4fbb60108 --- /dev/null +++ b/lapack-netlib/SRC/slarf1l.f @@ -0,0 +1,253 @@ +*> \brief \b SLARF1L applies an elementary reflector to a general rectangular +* matrix assuming v(lastv) = 1, where lastv is the last non-zero +* element +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download SLARF1L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* REAL TAU +* .. +* .. Array Arguments .. +* REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SLARF1L applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1, +*> where lastv is the last non-zero element. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is REAL array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV > 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is REAL +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1l +* +* ===================================================================== + SUBROUTINE SLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + REAL TAU +* .. +* .. Array Arguments .. + REAL C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC, FIRSTV +* .. +* .. External Subroutines .. + EXTERNAL SGEMV, SGER, SAXPY, SSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILASLR, ILASLC + EXTERNAL LSAME, ILASLR, ILASLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + FIRSTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V up to V(1). + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + I = 1 +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO ) + FIRSTV = FIRSTV + 1 + I = I + INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILASLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILASLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) +* + CALL SSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) + ELSE +* +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) +* + CALL SGEMV( 'Transpose', LASTV - FIRSTV, LASTC, ONE, + $ C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) +* + CALL SAXPY( LASTC, ONE, C( LASTV, 1 ), LDC, WORK, 1 ) +* +* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**T +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C( LASTV, 1 ), LDC ) +* +* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**T +* + CALL SGER( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) +* + CALL SSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) +* + CALL SGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE, + $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) +* + CALL SAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 ) +* +* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) +* + CALL SAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) +* +* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**T +* + CALL SGER( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) + END IF + END IF + RETURN +* +* End of SLARF1L +* + END diff --git a/lapack-netlib/SRC/sopmtr.f b/lapack-netlib/SRC/sopmtr.f index c1148e01f4..19e9f6af3a 100644 --- a/lapack-netlib/SRC/sopmtr.f +++ b/lapack-netlib/SRC/sopmtr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SOPMTR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -142,11 +140,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup upmtr * * ===================================================================== - SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, + SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, + $ WORK, $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -162,21 +162,16 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL FORWRD, LEFT, NOTRAN, UPPER INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -260,11 +255,8 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * * Apply H(i) * - AII = AP( II ) - AP( II ) = ONE - CALL SLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, - $ WORK ) - AP( II ) = AII + CALL SLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, + $ LDC, WORK ) * IF( FORWRD ) THEN II = II + I + 2 @@ -300,8 +292,6 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, END IF * DO 20 I = I1, I2, I3 - AII = AP( II ) - AP( II ) = ONE IF( LEFT ) THEN * * H(i) is applied to C(i+1:m,1:n) @@ -318,9 +308,8 @@ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, * * Apply H(i) * - CALL SLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - AP( II ) = AII + CALL SLARF1F( SIDE, MI, NI, AP( II ), 1, TAU( I ), + $ C( IC, JC ), LDC, WORK ) * IF( FORWRD ) THEN II = II + NQ - I + 1 diff --git a/lapack-netlib/SRC/sorbdb.f b/lapack-netlib/SRC/sorbdb.f index 351172ff16..17aba5db49 100644 --- a/lapack-netlib/SRC/sorbdb.f +++ b/lapack-netlib/SRC/sorbdb.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORBDB + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -255,7 +253,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unbdb * *> \par Further Details: * ===================== @@ -281,9 +279,11 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, + SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, + $ LDX12, $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -306,8 +306,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * .. Parameters .. REAL REALONE PARAMETER ( REALONE = 1.0E0 ) - REAL ONE - PARAMETER ( ONE = 1.0E0 ) * .. * .. Local Scalars .. LOGICAL COLMAJOR, LQUERY @@ -315,7 +313,8 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, REAL Z1, Z2, Z3, Z4 * .. * .. External Subroutines .. - EXTERNAL SAXPY, SLARF, SLARFGP, SSCAL, XERBLA + EXTERNAL SAXPY, SLARF1F, SLARFGP, SSCAL, + $ XERBLA * .. * .. External Functions .. REAL SNRM2 @@ -374,7 +373,7 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, IF( INFO .EQ. 0 ) THEN LWORKOPT = M - Q LWORKMIN = M - Q - WORK(1) = LWORKOPT + WORK(1) = REAL( LWORKOPT ) IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN INFO = -21 END IF @@ -398,14 +397,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SSCAL( P-I+1, Z1, X11(I,I), 1 ) ELSE CALL SSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), 1 ) - CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I,I-1), + CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I, + $ I-1), $ 1, X11(I,I), 1 ) END IF IF( I .EQ. 1 ) THEN CALL SSCAL( M-P-I+1, Z2, X21(I,I), 1 ) ELSE CALL SSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), 1 ) - CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I,I-1), + CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I, + $ I-1), $ 1, X21(I,I), 1 ) END IF * @@ -413,44 +414,47 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ SNRM2( P-I+1, X11(I,I), 1 ) ) * IF( P .GT. I ) THEN - CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, + $ TAUP1(I) ) ELSE IF( P .EQ. I ) THEN CALL SLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) END IF - X11(I,I) = ONE IF ( M-P .GT. I ) THEN CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, $ TAUP2(I) ) ELSE IF ( M-P .EQ. I ) THEN - CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, TAUP2(I) ) + CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, + $ TAUP2(I) ) END IF - X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), - $ X11(I,I+1), LDX11, WORK ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), + $ X11(I,I+1), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, TAUP1(I), - $ X12(I,I), LDX12, WORK ) + CALL SLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ TAUP1(I), X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ TAUP2(I), X21(I,I+1), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, TAUP2(I), - $ X22(I,I), LDX22, WORK ) + CALL SLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ TAUP2(I), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN CALL SSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1), $ LDX11 ) - CALL SAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), LDX21, + CALL SAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), + $ LDX21, $ X11(I,I+1), LDX11 ) END IF - CALL SSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), LDX12 ) - CALL SAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), LDX22, + CALL SSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), + $ LDX12 ) + CALL SAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), + $ LDX22, $ X12(I,I), LDX12 ) * IF( I .LT. Q ) @@ -465,7 +469,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, $ TAUQ1(I) ) END IF - X11(I,I+1) = ONE END IF IF ( Q+I-1 .LT. M ) THEN IF ( M-Q .EQ. I ) THEN @@ -476,21 +479,20 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, $ TAUQ2(I) ) END IF END IF - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL SLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) - CALL SLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL SLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), X11(I+1,I+1), LDX11, WORK ) + CALL SLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) END IF IF ( P .GT. I ) THEN - CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF ( M-P .GT. I ) THEN - CALL SLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + CALL SLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) END IF * END DO @@ -507,15 +509,14 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, $ TAUQ2(I) ) END IF - X12(I,I) = ONE * IF ( P .GT. I ) THEN - CALL SLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I), - $ X12(I+1,I), LDX12, WORK ) + CALL SLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X12(I+1,I), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL SLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, - $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) + $ CALL SLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) * END DO * @@ -531,10 +532,10 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), $ LDX22, TAUQ2(P+I) ) END IF - X22(Q+I,P+I) = ONE IF ( I .LT. M-P-Q ) THEN - CALL SLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22, - $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + CALL SLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), + $ LDX22, WORK ) END IF * END DO @@ -549,22 +550,25 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SSCAL( P-I+1, Z1, X11(I,I), LDX11 ) ELSE CALL SSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), LDX11 ) - CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1,I), + CALL SAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1, + $ I), $ LDX12, X11(I,I), LDX11 ) END IF IF( I .EQ. 1 ) THEN CALL SSCAL( M-P-I+1, Z2, X21(I,I), LDX21 ) ELSE - CALL SSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), LDX21 ) - CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1,I), + CALL SSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), + $ LDX21 ) + CALL SAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1, + $ I), $ LDX22, X21(I,I), LDX21 ) END IF * THETA(I) = ATAN2( SNRM2( M-P-I+1, X21(I,I), LDX21 ), $ SNRM2( P-I+1, X11(I,I), LDX11 ) ) * - CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) ) - X11(I,I) = ONE + CALL SLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, + $ TAUP1(I) ) IF ( I .EQ. M-P ) THEN CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, $ TAUP2(I) ) @@ -572,23 +576,22 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, $ TAUP2(I) ) END IF - X21(I,I) = ONE * IF ( Q .GT. I ) THEN - CALL SLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), - $ X11(I+1,I), LDX11, WORK ) + CALL SLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X11(I+1,I), LDX11, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, - $ TAUP1(I), X12(I,I), LDX12, WORK ) + CALL SLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) END IF IF ( Q .GT. I ) THEN - CALL SLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I), - $ X21(I+1,I), LDX21, WORK ) + CALL SLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X21(I+1,I), LDX21, WORK ) END IF IF ( M-Q+1 .GT. I ) THEN - CALL SLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, - $ TAUP2(I), X22(I,I), LDX22, WORK ) + CALL SLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) END IF * IF( I .LT. Q ) THEN @@ -612,7 +615,6 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, $ TAUQ1(I) ) END IF - X11(I+1,I) = ONE END IF IF ( M-Q .GT. I ) THEN CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, @@ -621,19 +623,18 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, $ TAUQ2(I) ) END IF - X12(I,I) = ONE * IF( I .LT. Q ) THEN - CALL SLARF( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK ) - CALL SLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK ) + CALL SLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL SLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) END IF - CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), - $ X12(I,I+1), LDX12, WORK ) + CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) IF ( M-P-I .GT. 0 ) THEN - CALL SLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, TAUQ2(I), - $ X22(I,I+1), LDX22, WORK ) + CALL SLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ TAUQ2(I), X22(I,I+1), LDX22, WORK ) END IF * END DO @@ -643,16 +644,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, DO I = Q + 1, P * CALL SSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 ) - CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) ) - X12(I,I) = ONE + CALL SLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) * IF ( P .GT. I ) THEN - CALL SLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), - $ X12(I,I+1), LDX12, WORK ) + CALL SLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ TAUQ2(I), X12(I,I+1), LDX12, WORK ) END IF IF( M-P-Q .GE. 1 ) - $ CALL SLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, TAUQ2(I), - $ X22(I,Q+1), LDX22, WORK ) + $ CALL SLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, + $ TAUQ2(I), X22(I,Q+1), LDX22, WORK ) * END DO * @@ -662,15 +663,16 @@ SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, * CALL SSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 ) IF ( M-P-Q .EQ. I ) THEN - CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), 1, + CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), + $ 1, $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE ELSE - CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, + CALL SLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), + $ 1, $ TAUQ2(P+I) ) - X22(P+I,Q+I) = ONE - CALL SLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1, - $ TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, WORK ) + CALL SLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), + $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, + $ WORK ) END IF * * diff --git a/lapack-netlib/SRC/sorbdb1.f b/lapack-netlib/SRC/sorbdb1.f index 191e5742a4..52fb3c7b58 100644 --- a/lapack-netlib/SRC/sorbdb1.f +++ b/lapack-netlib/SRC/sorbdb1.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORBDB1 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -174,7 +172,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unbdb1 * *> \par Further Details: * ===================== @@ -198,8 +196,10 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -216,10 +216,6 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * * ==================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E0 ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -227,7 +223,8 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, + $ XERBLA * .. * .. External Functions .. REAL SNRM2 @@ -264,7 +261,7 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LORBDB5 = Q-2 LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) LWORKMIN = LWORKOPT - WORK(1) = LWORKOPT + WORK(1) = REAL( LWORKOPT ) IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF @@ -285,22 +282,22 @@ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, THETA(I) = ATAN2( X21(I,I), X11(I,I) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I) = ONE - X21(I,I) = ONE - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), - $ LDX11, WORK(ILARF) ) - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) * IF( I .LT. Q ) THEN - CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S ) - CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) ) + CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, + $ S ) + CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, + $ TAUQ1(I) ) S = X21(I,I+1) - X21(I,I+1) = ONE - CALL SLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, + $ TAUQ1(I), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) PHI(I) = ATAN2( S, C ) diff --git a/lapack-netlib/SRC/sorbdb2.f b/lapack-netlib/SRC/sorbdb2.f index b2ff34bb1e..f4107d0d1f 100644 --- a/lapack-netlib/SRC/sorbdb2.f +++ b/lapack-netlib/SRC/sorbdb2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORBDB2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -172,7 +170,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unbdb2 * *> \par Further Details: * ===================== @@ -196,8 +194,10 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -215,8 +215,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * ==================================================================== * * .. Parameters .. - REAL NEGONE, ONE - PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0 ) + REAL NEGONE + PARAMETER ( NEGONE = -1.0E0 ) * .. * .. Local Scalars .. REAL C, S @@ -225,7 +225,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, SSCAL, + $ XERBLA * .. * .. External Functions .. REAL SNRM2 @@ -262,7 +263,7 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LORBDB5 = Q-1 LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) LWORKMIN = LWORKOPT - WORK(1) = LWORKOPT + WORK(1) = REAL( LWORKOPT ) IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF @@ -279,15 +280,15 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, DO I = 1, P * IF( I .GT. 1 ) THEN - CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S ) + CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, + $ S ) END IF CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) C = X11(I,I) - X11(I,I) = ONE - CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, + $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) ) S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 $ + SNRM2( M-P-I+1, X21(I,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) @@ -302,13 +303,11 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, PHI(I) = ATAN2( X11(I+1,I), X21(I,I) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X11(I+1,I) = ONE - CALL SLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), - $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) END IF - X21(I,I) = ONE - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) * END DO * @@ -316,9 +315,8 @@ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * DO I = P + 1, Q CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) - X21(I,I) = ONE - CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), - $ X21(I,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) END DO * RETURN diff --git a/lapack-netlib/SRC/sorbdb3.f b/lapack-netlib/SRC/sorbdb3.f index 99478c5d0d..3cf8f97355 100644 --- a/lapack-netlib/SRC/sorbdb3.f +++ b/lapack-netlib/SRC/sorbdb3.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORBDB3 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -173,7 +171,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unbdb3 * *> \par Further Details: * ===================== @@ -197,8 +195,10 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -215,10 +215,6 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * * ==================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E0 ) -* .. * .. Local Scalars .. REAL C, S INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, @@ -226,7 +222,8 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, + $ XERBLA * .. * .. External Functions .. REAL SNRM2 @@ -263,7 +260,7 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LORBDB5 = Q-1 LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) LWORKMIN = LWORKOPT - WORK(1) = LWORKOPT + WORK(1) = REAL( LWORKOPT ) IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF @@ -280,16 +277,16 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, DO I = 1, M-P * IF( I .GT. 1 ) THEN - CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S ) + CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, + $ S ) END IF * CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) S = X21(I,I) - X21(I,I) = ONE - CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) C = SQRT( SNRM2( P-I+1, X11(I,I), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 ) THETA(I) = ATAN2( S, C ) @@ -299,17 +296,16 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ WORK(IORBDB5), LORBDB5, CHILDINFO ) CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) IF( I .LT. M-P ) THEN - CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) ) + CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, + $ TAUP2(I) ) PHI(I) = ATAN2( X21(I+1,I), X11(I,I) ) C = COS( PHI(I) ) S = SIN( PHI(I) ) - X21(I+1,I) = ONE - CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), - $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) END IF - X11(I,I) = ONE - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), - $ LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), LDX11, WORK(ILARF) ) * END DO * @@ -317,9 +313,8 @@ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * DO I = M-P + 1, Q CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) - X11(I,I) = ONE - CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1), - $ LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), LDX11, WORK(ILARF) ) END DO * RETURN diff --git a/lapack-netlib/SRC/sorbdb4.f b/lapack-netlib/SRC/sorbdb4.f index 0fef5b759b..4bd1affa45 100644 --- a/lapack-netlib/SRC/sorbdb4.f +++ b/lapack-netlib/SRC/sorbdb4.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORBDB4 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -184,7 +182,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unbdb4 * *> \par Further Details: * ===================== @@ -208,9 +206,11 @@ *> Algorithms, 50(1):33-65, 2009. *> * ===================================================================== - SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, + SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, $ INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -228,8 +228,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * ==================================================================== * * .. Parameters .. - REAL NEGONE, ONE, ZERO - PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 ) + REAL NEGONE, ZERO + PARAMETER ( NEGONE = -1.0E0, ZERO = 0.0E0 ) * .. * .. Local Scalars .. REAL C, S @@ -238,7 +238,8 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LOGICAL LQUERY * .. * .. External Subroutines .. - EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA + EXTERNAL SLARF1F, SLARFGP, SORBDB5, SROT, SSCAL, + $ XERBLA * .. * .. External Functions .. REAL SNRM2 @@ -276,7 +277,7 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, LWORKOPT = ILARF + LLARF - 1 LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) LWORKMIN = LWORKOPT - WORK(1) = LWORKOPT + WORK(1) = REAL( LWORKOPT ) IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN INFO = -14 END IF @@ -301,43 +302,40 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, $ LORBDB5, CHILDINFO ) CALL SSCAL( P, NEGONE, PHANTOM(1), 1 ) CALL SLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) - CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) ) + CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, + $ TAUP2(1) ) THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - PHANTOM(1) = ONE - PHANTOM(P+1) = ONE - CALL SLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11, - $ WORK(ILARF) ) - CALL SLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21, - $ LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, + $ LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), + $ X21, LDX21, WORK(ILARF) ) ELSE CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) CALL SSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) - CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) ) + CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, + $ TAUP1(I) ) CALL SLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, $ TAUP2(I) ) THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) ) C = COS( THETA(I) ) S = SIN( THETA(I) ) - X11(I,I-1) = ONE - X21(I,I-1) = ONE - CALL SLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), - $ X11(I,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I), - $ X21(I,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ TAUP2(I), X21(I,I), LDX21, WORK(ILARF) ) END IF * CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) C = X21(I,I) - X21(I,I) = ONE - CALL SLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), - $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) IF( I .LT. M-Q ) THEN S = SQRT( SNRM2( P-I, X11(I+1,I), 1 )**2 $ + SNRM2( M-P-I, X21(I+1,I), 1 )**2 ) @@ -350,21 +348,21 @@ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, * DO I = M - Q + 1, P CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) - X11(I,I) = ONE - CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X11(I+1,I), LDX11, WORK(ILARF) ) - CALL SLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), - $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL SLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) END DO * * Reduce the bottom-right portion of X21 to [ 0 I ] * DO I = P + 1, Q - CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21, + CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), + $ LDX21, $ TAUQ1(I) ) - X21(M-Q+I-P,I) = ONE - CALL SLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I), - $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL SLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, + $ TAUQ1(I), X21(M-Q+I-P+1,I), LDX21, + $ WORK(ILARF) ) END DO * RETURN diff --git a/lapack-netlib/SRC/sorg2l.f b/lapack-netlib/SRC/sorg2l.f index aa0dd0a08e..bf5c9b0ec7 100644 --- a/lapack-netlib/SRC/sorg2l.f +++ b/lapack-netlib/SRC/sorg2l.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORG2L + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,10 +105,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup ung2l * * ===================================================================== SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -133,7 +132,7 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1L, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -177,8 +176,8 @@ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i) from the left * A( M-N+II, II ) = ONE - CALL SLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, - $ LDA, WORK ) + CALL SLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), + $ A, LDA, WORK ) CALL SSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) A( M-N+II, II ) = ONE - TAU( I ) * diff --git a/lapack-netlib/SRC/sorg2r.f b/lapack-netlib/SRC/sorg2r.f index 3a8aa33a02..c6bbe7506a 100644 --- a/lapack-netlib/SRC/sorg2r.f +++ b/lapack-netlib/SRC/sorg2r.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORG2R + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,10 +105,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup ung2r * * ===================================================================== SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -133,7 +132,7 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1F, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -176,9 +175,8 @@ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(i:m,i:n) from the left * IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) + CALL SLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) END IF IF( I.LT.M ) $ CALL SSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) diff --git a/lapack-netlib/SRC/sorgl2.f b/lapack-netlib/SRC/sorgl2.f index d85c388749..2bea2836f9 100644 --- a/lapack-netlib/SRC/sorgl2.f +++ b/lapack-netlib/SRC/sorgl2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORGL2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -106,10 +104,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup ungl2 * * ===================================================================== SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -132,7 +131,7 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1F, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -180,9 +179,8 @@ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) * IF( I.LT.N ) THEN IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) + CALL SLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), A( I+1, I ), LDA, WORK ) END IF CALL SSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) END IF diff --git a/lapack-netlib/SRC/sorgr2.f b/lapack-netlib/SRC/sorgr2.f index 12bb90c782..aca697e0cd 100644 --- a/lapack-netlib/SRC/sorgr2.f +++ b/lapack-netlib/SRC/sorgr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORGR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -107,10 +105,11 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup ungr2 * * ===================================================================== SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -133,7 +132,7 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) INTEGER I, II, J, L * .. * .. External Subroutines .. - EXTERNAL SLARF, SSCAL, XERBLA + EXTERNAL SLARF1L, SSCAL, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -181,8 +180,8 @@ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO ) * Apply H(i) to A(1:m-k+i,1:n-k+i) from the right * A( II, N-M+II ) = ONE - CALL SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ), - $ A, LDA, WORK ) + CALL SLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) A( II, N-M+II ) = ONE - TAU( I ) * diff --git a/lapack-netlib/SRC/sorm2l.f b/lapack-netlib/SRC/sorm2l.f index 2f6e3abbc3..6de9c5d8e2 100644 --- a/lapack-netlib/SRC/sorm2l.f +++ b/lapack-netlib/SRC/sorm2l.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORM2L + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unm2l * * ===================================================================== SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,16 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -262,11 +256,8 @@ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( NQ-K+I, I ) - A( NQ-K+I, I ) = ONE - CALL SLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, + CALL SLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, $ WORK ) - A( NQ-K+I, I ) = AII 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/sorm2r.f b/lapack-netlib/SRC/sorm2r.f index 0e0747a005..b1fd6263f6 100644 --- a/lapack-netlib/SRC/sorm2r.f +++ b/lapack-netlib/SRC/sorm2r.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORM2R + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unm2r * * ===================================================================== SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,16 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,11 +260,8 @@ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII + CALL SLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, + $ JC ), LDC, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/sorml2.f b/lapack-netlib/SRC/sorml2.f index c5705c799e..0f79de7df1 100644 --- a/lapack-netlib/SRC/sorml2.f +++ b/lapack-netlib/SRC/sorml2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORML2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unml2 * * ===================================================================== SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,16 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1F, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -266,11 +260,8 @@ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, I ) - A( I, I ) = ONE - CALL SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII + CALL SLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/SRC/sormr2.f b/lapack-netlib/SRC/sormr2.f index cefe1d3092..c170f63c77 100644 --- a/lapack-netlib/SRC/sormr2.f +++ b/lapack-netlib/SRC/sormr2.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SORMR2 + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -151,11 +149,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup unmr2 * * ===================================================================== SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, $ WORK, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -171,21 +170,16 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * ===================================================================== * -* .. Parameters .. - REAL ONE - PARAMETER ( ONE = 1.0E+0 ) -* .. * .. Local Scalars .. LOGICAL LEFT, NOTRAN INTEGER I, I1, I2, I3, MI, NI, NQ - REAL AII * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. External Subroutines .. - EXTERNAL SLARF, XERBLA + EXTERNAL SLARF1L, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC MAX @@ -262,11 +256,8 @@ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, * * Apply H(i) * - AII = A( I, NQ-K+I ) - A( I, NQ-K+I ) = ONE - CALL SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC, - $ WORK ) - A( I, NQ-K+I ) = AII + CALL SLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, + $ LDC, WORK ) 10 CONTINUE RETURN * diff --git a/lapack-netlib/dgebd2.f b/lapack-netlib/dgebd2.f new file mode 100644 index 0000000000..b94bcc4784 --- /dev/null +++ b/lapack-netlib/dgebd2.f @@ -0,0 +1,312 @@ +*> \brief \b DGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), +* $ TAUQ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEBD2 reduces a real general m by n matrix A to upper or lower +*> bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. +*> +*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows in the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n general matrix to be reduced. +*> On exit, +*> if m >= n, the diagonal and the first superdiagonal are +*> overwritten with the upper bidiagonal matrix B; the +*> elements below the diagonal, with the array TAUQ, represent +*> the orthogonal matrix Q as a product of elementary +*> reflectors, and the elements above the first superdiagonal, +*> with the array TAUP, represent the orthogonal matrix P as +*> a product of elementary reflectors; +*> if m < n, the diagonal and the first subdiagonal are +*> overwritten with the lower bidiagonal matrix B; the +*> elements below the first subdiagonal, with the array TAUQ, +*> represent the orthogonal matrix Q as a product of +*> elementary reflectors, and the elements above the diagonal, +*> with the array TAUP, represent the orthogonal matrix P as +*> a product of elementary reflectors. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (min(M,N)) +*> The diagonal elements of the bidiagonal matrix B: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) +*> The off-diagonal elements of the bidiagonal matrix B: +*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; +*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. +*> \endverbatim +*> +*> \param[out] TAUQ +*> \verbatim +*> TAUQ is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix Q. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP +*> \verbatim +*> TAUP is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the orthogonal matrix P. See Further Details. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (max(M,N)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gebd2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrices Q and P are represented as products of elementary +*> reflectors: +*> +*> If m >= n, +*> +*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T +*> +*> where tauq and taup are real scalars, and v and u are real vectors; +*> v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); +*> u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> If m < n, +*> +*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T +*> +*> where tauq and taup are real scalars, and v and u are real vectors; +*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); +*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> The contents of A on exit are illustrated by the following examples: +*> +*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): +*> +*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) +*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) +*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) +*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) +*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) +*> ( v1 v2 v3 v4 v5 ) +*> +*> where d and e denote diagonal and off-diagonal elements of B, vi +*> denotes an element of the vector defining H(i), and ui an element of +*> the vector defining G(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), + $ TAUQ( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. 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.LT.0 ) THEN + CALL XERBLA( 'DGEBD2', -INFO ) + RETURN + END IF +* + IF( M.GE.N ) THEN +* +* Reduce to upper bidiagonal form +* + DO 10 I = 1, N +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAUQ( I ) ) + D( I ) = A( I, I ) +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + IF( I.LT.N ) + $ CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ TAUQ( I ), + $ A( I, I+1 ), LDA, WORK ) +* + IF( I.LT.N ) THEN +* +* Generate elementary reflector G(i) to annihilate +* A(i,i+2:n) +* + CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), + $ LDA, TAUP( I ) ) + E( I ) = A( I, I+1 ) +* +* Apply G(i) to A(i+1:m,i+1:n) from the right +* + CALL DLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) + ELSE + TAUP( I ) = ZERO + END IF + 10 CONTINUE + ELSE +* +* Reduce to lower bidiagonal form +* + DO 20 I = 1, M +* +* Generate elementary reflector G(i) to annihilate A(i,i+1:n) +* + CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), + $ LDA, + $ TAUP( I ) ) + D( I ) = A( I, I ) +* +* Apply G(i) to A(i+1:m,i:n) from the right +* + IF( I.LT.M ) + $ CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) +* + IF( I.LT.M ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:m,i) +* + CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), + $ 1, + $ TAUQ( I ) ) + E( I ) = A( I+1, I ) +* +* Apply H(i) to A(i+1:m,i+1:n) from the left +* + CALL DLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, + $ TAUQ( I ), + $ A( I+1, I+1 ), LDA, WORK ) + ELSE + TAUQ( I ) = ZERO + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGEBD2 +* + END diff --git a/lapack-netlib/dgehd2.f b/lapack-netlib/dgehd2.f new file mode 100644 index 0000000000..eaaf091a60 --- /dev/null +++ b/lapack-netlib/dgehd2.f @@ -0,0 +1,217 @@ +*> \brief \b DGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEHD2 reduces a real general matrix A to upper Hessenberg form H by +*> an orthogonal similarity transformation: Q**T * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to DGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= max(1,N). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the n by n general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the orthogonal matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gehd2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL DLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i) to A(i+1:ihi,i+1:n) from the left +* + CALL DLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ), + $ A( I+1, I+1 ), LDA, WORK ) +* + 10 CONTINUE +* + RETURN +* +* End of DGEHD2 +* + END diff --git a/lapack-netlib/dgelq2.f b/lapack-netlib/dgelq2.f new file mode 100644 index 0000000000..b7c8c933d8 --- /dev/null +++ b/lapack-netlib/dgelq2.f @@ -0,0 +1,193 @@ +*> \brief \b DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGELQ2 computes an LQ factorization of a real m-by-n matrix A: +*> +*> A = ( L 0 ) * Q +*> +*> where: +*> +*> Q is a n-by-n orthogonal matrix; +*> L is a lower-triangular m-by-m matrix; +*> 0 is a m-by-(n-m) zero matrix, if m < n. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the m by min(m,n) lower trapezoidal matrix L (L is +*> lower triangular if m <= n); the elements above the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gelq2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'DGELQ2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i,i+1:n) +* + CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, + $ TAU( I ) ) + IF( I.LT.M ) THEN +* +* Apply H(i) to A(i+1:m,i:n) from the right +* + CALL DLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), + $ A( I+1, I ), LDA, WORK ) + END IF + 10 CONTINUE + RETURN +* +* End of DGELQ2 +* + END diff --git a/lapack-netlib/dgeqp3rk.f b/lapack-netlib/dgeqp3rk.f new file mode 100644 index 0000000000..8645f88ebb --- /dev/null +++ b/lapack-netlib/dgeqp3rk.f @@ -0,0 +1,1073 @@ +*> \brief \b DGEQP3RK computes a truncated Householder QR factorization with column pivoting of a real m-by-n matrix A by using Level 3 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a real +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M orthogonal matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a real M-by-NRHS +*> matrix B with Q(K)**T * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**T * B, the matrix B with the orthogonal +*> transformation Q(K)**T applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M orthogonal matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**T, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a real scalar, +*> v is a real vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,1:K) together with TAU(1:K) represent the +*> orthogonal matrix Q(K) as a product of K Householder +*> elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**T * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> LWORK >= 1, if MIN(M,N) = 0, and +*> LWORK >= (3*N+NRHS-1), otherwise. +*> For optimal performance LWORK >= (2*N + NB*( N+NRHS+1 )), +*> where NB is the optimal block size for DGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine DLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> DGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in DGEQP3 routine which uses +*> DLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> https://doi.org/10.1137/S1064827595296732 +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> https://doi.org/10.1145/1377612.1377616 +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + DOUBLE PRECISION EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL DLAQP2RK, DLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, DNRM2, IDAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in DLAQP2RK. +* 1) DGEQP3RK and DLAQP2RK: 2*N to store full and partial +* column 2-norms. +* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in DLARF1F subroutine inside DLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = 3*N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'DGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in DLAQP2RK and blocked BLAS 3 code +* in DLAQP3RK. +* 1) DGEQP3RK, DLAQP2RK, DLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) DLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in DLARF1F subroutine to apply an elementary reflector +* from the left. +* 3) DLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) DLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = DBLE( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + WORK( J ) = DNRM2( M, A( 1, J ), 1 ) + WORK( N+J ) = WORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = IDAMAX( N, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP1 ) +* +* ==================================================================. +* + IF( DISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = ZERO + END DO + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = ZERO + END DO +* + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'DGEQP3RK', ' ', M, N, -1, + $ -1 )) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL DLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL DLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), WORK( J ), WORK( N+J ), + $ WORK( 2*N+1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, WORK( K+1 ), 1 ) + MAXC2NRMK = WORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = ZERO + END DO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) +* + RETURN +* +* End of DGEQP3RK +* + END diff --git a/lapack-netlib/dgeqr2.f b/lapack-netlib/dgeqr2.f new file mode 100644 index 0000000000..94872f54e6 --- /dev/null +++ b/lapack-netlib/dgeqr2.f @@ -0,0 +1,193 @@ +*> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQR2 computes a QR factorization of a real m-by-n matrix A: +*> +*> A = Q * ( R ), +*> ( 0 ) +*> +*> where: +*> +*> Q is a m-by-m orthogonal matrix; +*> R is an upper-triangular n-by-n matrix; +*> 0 is a (m-n)-by-n zero matrix, if m > n. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(m,n) by n upper trapezoidal matrix R (R is +*> upper triangular if m >= n); the elements below the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'DGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2 +* + END diff --git a/lapack-netlib/dgeqr2p.f b/lapack-netlib/dgeqr2p.f new file mode 100644 index 0000000000..cce4d346ea --- /dev/null +++ b/lapack-netlib/dgeqr2p.f @@ -0,0 +1,197 @@ +*> \brief \b DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEQR2P computes a QR factorization of a real m-by-n matrix A: +*> +*> A = Q * ( R ), +*> ( 0 ) +*> +*> where: +*> +*> Q is a m-by-m orthogonal matrix; +*> R is an upper-triangular n-by-n matrix with nonnegative diagonal +*> entries; +*> 0 is a (m-n)-by-n zero matrix, if m > n. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(m,n) by n upper trapezoidal matrix R (R is +*> upper triangular if m >= n). The diagonal entries of R are +*> nonnegative; the elements below the diagonal, +*> with the array TAU, represent the orthogonal matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqr2p +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**T +*> +*> where tau is a real scalar, and v is a real vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> +*> See Lapack Working Note 203 for details +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFGP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'DGEQR2P', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL DLARFGP( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i) to A(i:m,i+1:n) from the left +* + CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + 10 CONTINUE + RETURN +* +* End of DGEQR2P +* + END diff --git a/lapack-netlib/dlaqp2.f b/lapack-netlib/dlaqp2.f new file mode 100644 index 0000000000..d32f075484 --- /dev/null +++ b/lapack-netlib/dlaqp2.f @@ -0,0 +1,254 @@ +*> \brief \b DLAQP2 computes a QR factorization with column pivoting of the matrix block. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, +* WORK ) +* +* .. Scalar Arguments .. +* INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. +* INTEGER JPVT( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP2 computes a QR factorization with column pivoting of +*> the block A(OFFSET+1:M,1:N). +*> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] OFFSET +*> \verbatim +*> OFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but no factorized. OFFSET >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is +*> the triangular factor obtained; the elements in block +*> A(OFFSET+1:M,1:N) below the diagonal, together with the +*> array TAU, represent the orthogonal matrix Q as a product of +*> elementary reflectors. Block A(1:OFFSET,1:N) has been +*> accordingly pivoted, but no factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] JPVT +*> \verbatim +*> JPVT is INTEGER array, dimension (N) +*> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted +*> to the front of A*P (a leading column); if JPVT(i) = 0, +*> the i-th column of A is a free column. +*> On exit, if JPVT(i) = k, then the i-th column of A*P +*> was the k-th column of A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2 +* +*> \par Contributors: +* ================== +*> +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain +*> X. Sun, Computer Science Dept., Duke University, USA +*> \n +*> Partial column norm updating strategy modified on April 2011 +*> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, +*> University of Zagreb, Croatia. +* +*> \par References: +* ================ +*> +*> LAPACK Working Note 176 +* +*> [PDF] +* +* ===================================================================== + SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL IDAMAX, DLAMCH, DNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), + $ 1, + $ TAU( I ) ) + ELSE + CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. +* + CALL DLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) ) + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of DLAQP2 +* + END diff --git a/lapack-netlib/dlaqp2rk.f b/lapack-netlib/dlaqp2rk.f new file mode 100644 index 0000000000..ae2d62cac5 --- /dev/null +++ b/lapack-netlib/dlaqp2rk.f @@ -0,0 +1,700 @@ +*> \brief \b DLAQP2RK computes truncated QR factorization with column pivoting of a real matrix block using Level 2 BLAS and overwrites a real m-by-nrhs matrix B with Q**T * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), +* $ WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of a real matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**T * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine DGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine DGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the orthogonal matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**T. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N-1) +*> Used in DLARF1F subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> https://doi.org/10.1137/S1064827595296732 +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> https://doi.org/10.1145/1377612.1377616 +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE DLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), + $ WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, + $ KBOUND, MINMNFACT, MINMNUPDT + DOUBLE PRECISION HUGEVAL, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFG, DSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KBOUND = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KBOUND +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to ZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = ZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL DSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = ZERO. +* + IF( I.LT.M ) THEN + CALL DLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = ZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since DLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by DLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by DLARFG is covered by checking TAU(KK) for NaN. +* + IF( DISNAN( TAU(KK) ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAU( KK ) + RELMAXC2NRMK = TAU( KK ) +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**T to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = ZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + CALL DLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ TAU( KK ), A( I, KK+1 ), LDA, WORK( 1 ) ) + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KBOUND +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to ZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = ZERO + END DO +* + RETURN +* +* End of DLAQP2RK +* + END diff --git a/lapack-netlib/dlaqr2.f b/lapack-netlib/dlaqr2.f new file mode 100644 index 0000000000..02ae83cb5d --- /dev/null +++ b/lapack-netlib/dlaqr2.f @@ -0,0 +1,689 @@ +*> \brief \b DLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +* LDT, NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLAQR2 is identical to DLAQR3 except that it avoids +*> recursion by calling DLAHQR instead of DLAQR4. +*> +*> Aggressive early deflation: +*> +*> This subroutine accepts as input an upper Hessenberg matrix +*> H and performs an orthogonal similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an orthogonal similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the quasi-triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the orthogonal matrix Z is updated so +*> so that the orthogonal Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the orthogonal matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 <= NW <= (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by an orthogonal +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> Leading dimension of H just as declared in the calling +*> subroutine. N <= LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 <= LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array, dimension (KBOT) +*> \endverbatim +*> +*> \param[out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array, dimension (KBOT) +*> On output, the real and imaginary parts of approximate +*> eigenvalues that may be used for shifts are stored in +*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +*> The real and imaginary parts of converged eigenvalues +*> are stored in SR(KBOT-ND+1) through SR(KBOT) and +*> SI(KBOT-ND+1) through SI(KBOT), respectively. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> The number of columns of T. NH >= NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of T just as declared in the +*> calling subroutine. NW <= LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> The number of rows of work array WV available for +*> workspace. NV >= NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> The leading dimension of W just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; DLAQR2 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqr2 +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, + $ LWKOPT + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLACPY, + $ DLAHQR, + $ DLANV2, DLARF1F, DLARFG, DLASET, DORMHR, DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORMHR ==== +* + CALL DORMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, + $ LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( 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 +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT.BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undeflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) +* + CALL DLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + 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 ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR2 ==== +* + END diff --git a/lapack-netlib/dlaqr3.f b/lapack-netlib/dlaqr3.f new file mode 100644 index 0000000000..9ddd8c7a4a --- /dev/null +++ b/lapack-netlib/dlaqr3.f @@ -0,0 +1,700 @@ +*> \brief \b DLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, +* LDT, NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), +* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), +* $ Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Aggressive early deflation: +*> +*> DLAQR3 accepts as input an upper Hessenberg matrix +*> H and performs an orthogonal similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an orthogonal similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the quasi-triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the orthogonal matrix Z is updated so +*> so that the orthogonal Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the orthogonal matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 <= NW <= (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is DOUBLE PRECISION array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by an orthogonal +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> Leading dimension of H just as declared in the calling +*> subroutine. N <= LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 <= LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SR +*> \verbatim +*> SR is DOUBLE PRECISION array, dimension (KBOT) +*> \endverbatim +*> +*> \param[out] SI +*> \verbatim +*> SI is DOUBLE PRECISION array, dimension (KBOT) +*> On output, the real and imaginary parts of approximate +*> eigenvalues that may be used for shifts are stored in +*> SR(KBOT-ND-NS+1) through SR(KBOT-ND) and +*> SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. +*> The real and imaginary parts of converged eigenvalues +*> are stored in SR(KBOT-ND+1) through SR(KBOT) and +*> SI(KBOT-ND+1) through SI(KBOT), respectively. +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> The number of columns of T. NH >= NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is DOUBLE PRECISION array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of T just as declared in the +*> calling subroutine. NW <= LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> The number of rows of work array WV available for +*> workspace. NV >= NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is DOUBLE PRECISION array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> The leading dimension of W just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; DLAQR3 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqr3 +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, + $ LDT, NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), + $ V( LDV, * ), WORK( * ), WV( LDWV, * ), + $ Z( LDZ, * ) +* .. +* +* ================================================================ +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S, + $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL, + $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN + LOGICAL BULGE, SORTED +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEHRD, DGEMM, DLACPY, DLAHQR, + $ DLANV2, + $ DLAQR4, DLARF1F, DLARFG, DLASET, DORMHR, DTREXC +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to DGEHRD ==== +* + CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to DORMHR ==== +* + 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 ==== +* + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, + $ JW, + $ V, LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = ONE / SAFMIN + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SR( KWTOP ) = H( KWTOP, KWTOP ) + SI( KWTOP ) = ZERO + NS = 1 + ND = 0 + IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( 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 +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) +* + CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ), + $ SI( KWTOP ), 1, JW, V, LDV, INFQR ) + END IF +* +* ==== DTREXC needs a clean margin near the diagonal ==== +* + DO 10 J = 1, JW - 3 + T( J+2, J ) = ZERO + T( J+3, J ) = ZERO + 10 CONTINUE + IF( JW.GT.2 ) + $ T( JW, JW-2 ) = ZERO +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + 20 CONTINUE + IF( ILST.LE.NS ) THEN + IF( NS.EQ.1 ) THEN + BULGE = .FALSE. + ELSE + BULGE = T( NS, NS-1 ).NE.ZERO + END IF +* +* ==== Small spike tip test for deflation ==== +* + IF( .NOT. BULGE ) THEN +* +* ==== Real eigenvalue ==== +* + FOO = ABS( T( NS, NS ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 1 + ELSE +* +* ==== Undeflatable. Move it up out of the way. +* . (DTREXC can not fail in this case.) ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, + $ INFO ) + ILST = ILST + 1 + END IF + ELSE +* +* ==== Complex conjugate pair ==== +* + FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )* + $ SQRT( ABS( T( NS-1, NS ) ) ) + IF( FOO.EQ.ZERO ) + $ FOO = ABS( S ) + IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE. + $ MAX( SMLNUM, ULP*FOO ) ) THEN +* +* ==== Deflatable ==== +* + NS = NS - 2 + ELSE +* +* ==== Undeflatable. Move them up out of the way. +* . Fortunately, DTREXC does the right thing with +* . ILST in case of a rare exchange failure. ==== +* + IFST = NS + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, + $ INFO ) + ILST = ILST + 2 + END IF + END IF +* +* ==== End deflation detection loop ==== +* + GO TO 20 + END IF +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting diagonal blocks of T improves accuracy for +* . graded matrices. Bubble sort deals well with +* . exchange failures. ==== +* + SORTED = .false. + I = NS + 1 + 30 CONTINUE + IF( SORTED ) + $ GO TO 50 + SORTED = .true. +* + KEND = I - 1 + I = INFQR + 1 + IF( I.EQ.NS ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + 40 CONTINUE + IF( K.LE.KEND ) THEN + IF( K.EQ.I+1 ) THEN + EVI = ABS( T( I, I ) ) + ELSE + EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )* + $ SQRT( ABS( T( I, I+1 ) ) ) + END IF +* + IF( K.EQ.KEND ) THEN + EVK = ABS( T( K, K ) ) + ELSE IF( T( K+1, K ).EQ.ZERO ) THEN + EVK = ABS( T( K, K ) ) + ELSE + EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )* + $ SQRT( ABS( T( K, K+1 ) ) ) + END IF +* + IF( EVI.GE.EVK ) THEN + I = K + ELSE + SORTED = .false. + IFST = I + ILST = K + CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ WORK, + $ INFO ) + IF( INFO.EQ.0 ) THEN + I = ILST + ELSE + I = K + END IF + END IF + IF( I.EQ.KEND ) THEN + K = I + 1 + ELSE IF( T( I+1, I ).EQ.ZERO ) THEN + K = I + 1 + ELSE + K = I + 2 + END IF + GO TO 40 + END IF + GO TO 30 + 50 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + I = JW + 60 CONTINUE + IF( I.GE.INFQR+1 ) THEN + IF( I.EQ.INFQR+1 ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN + SR( KWTOP+I-1 ) = T( I, I ) + SI( KWTOP+I-1 ) = ZERO + I = I - 1 + ELSE + AA = T( I-1, I-1 ) + CC = T( I, I-1 ) + BB = T( I-1, I ) + DD = T( I, I ) + CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ), + $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ), + $ SI( KWTOP+I-1 ), CS, SN ) + I = I - 2 + END IF + GO TO 60 + END IF +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL DCOPY( NS, V, LDV, WORK, 1 ) + BETA = WORK( 1 ) + CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU ) +* + CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) +* + CALL DLARF1F( 'L', NS, JW, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL DLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 ) + CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + 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 ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 70 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) + 70 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 80 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 80 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 90 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 90 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DBLE( LWKOPT ) +* +* ==== End of DLAQR3 ==== +* + END diff --git a/lapack-netlib/dlarf1f.f b/lapack-netlib/dlarf1f.f new file mode 100644 index 0000000000..c65035c61f --- /dev/null +++ b/lapack-netlib/dlarf1f.f @@ -0,0 +1,291 @@ +*> \brief \b DLARF1F applies an elementary reflector to a general rectangular +* matrix assuming v(1) = 1. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DLARF1F + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARF1F applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. V(1) is not referenced or modified. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* To take advantage of the fact that v(1) = 1, we do the following +* v = [ 1 v_2 ]**T +* If SIDE='L' +* |-----| +* | C_1 | +* C =| C_2 | +* |-----| +* C_1\in\mathbb{R}^{1\times n}, C_2\in\mathbb{R}^{m-1\times n} +* So we compute: +* C = HC = (I - \tau vv**T)C +* = C - \tau vv**T C +* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T +* = C_1**T + C_2**T v ( DGEMM then DAXPY ) +* C = C - \tau vv**T C +* = C - \tau vw**T +* Giving us C_1 = C_1 - \tau w**T ( DAXPY ) +* and +* C_2 = C_2 - \tau v_2w**T ( DGER ) +* If SIDE='R' +* +* C = [ C_1 C_2 ] +* C_1\in\mathbb{R}^{m\times 1}, C_2\in\mathbb{R}^{m\times n-1} +* So we compute: +* C = CH = C(I - \tau vv**T) +* = C - \tau Cvv**T +* +* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T +* = C_1 + C_2v_2 ( DGEMM then DAXPY ) +* C = C - \tau Cvv**T +* = C - \tau wv**T +* Giving us C_1 = C_1 - \tau w ( DAXPY ) +* and +* C_2 = C_2 - \tau wv_2**T ( DGER ) +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf +* +* ===================================================================== + SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER, DAXPY, DSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. +! Since we are assuming that V(1) = 1, and it is not stored, so we +! shouldn't access it. + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + ! Check if lastv = 1. This means v = 1, So we just need to compute + ! C := HC = (1-\tau)C. + IF( LASTV.EQ.1 ) THEN +* +* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc) +* + CALL DSCAL(LASTC, ONE - TAU, C, LDC) + ELSE +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + ! w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1) + CALL DGEMV( 'Transpose', LASTV-1, LASTC, ONE, C(1+1,1), + $ LDC, V(1+INCV), INCV, ZERO, WORK, 1) + ! w(1:lastc,1) += C(1,1:lastc)**T * v(1,1) = C(1,1:lastc)**T + CALL DAXPY(LASTC, ONE, C, LDC, WORK, 1) +* +* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T +* + ! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**T + ! = C(...) - tau * w(1:lastc,1)**T + CALL DAXPY(LASTC, -TAU, WORK, 1, C, LDC) + ! C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**T + CALL DGER(LASTV-1, LASTC, -TAU, V(1+INCV), INCV, WORK, 1, + $ C(1+1,1), LDC) + END IF + ELSE +* +* Form C * H +* + ! Check if n = 1. This means v = 1, so we just need to compute + ! C := CH = C(1-\tau). + IF( LASTV.EQ.1 ) THEN +* +* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1) +* + CALL DSCAL(LASTC, ONE - TAU, C, 1) + ELSE +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + ! w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) + CALL DGEMV( 'No transpose', LASTC, LASTV-1, ONE, + $ C(1,1+1), LDC, V(1+INCV), INCV, ZERO, WORK, 1 ) + ! w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1) + CALL DAXPY(LASTC, ONE, C, 1, WORK, 1) +* +* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T +* + ! C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)**T + ! = C(...) - tau * w(1:lastc,1) + CALL DAXPY(LASTC, -TAU, WORK, 1, C, 1) + ! C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:lastv)**T + CALL DGER( LASTC, LASTV-1, -TAU, WORK, 1, V(1+INCV), + $ INCV, C(1,1+1), LDC ) + END IF + END IF + RETURN +* +* End of DLARF1F +* + END diff --git a/lapack-netlib/dlarf1l.f b/lapack-netlib/dlarf1l.f new file mode 100644 index 0000000000..d225701fcd --- /dev/null +++ b/lapack-netlib/dlarf1l.f @@ -0,0 +1,251 @@ +*> \brief \b DLARF1L applies an elementary reflector to a general rectangular +* matrix assuming v(lastv) = 1 where lastv is the last non-zero +* element +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DLARF1L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. +* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DLARF1L applies a real elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**T +*> +*> where tau is a real scalar and v is a real vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf +* +* ===================================================================== + SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, FIRSTV, LASTV, LASTC +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DGER, DSCAL +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILADLR, ILADLC + EXTERNAL LSAME, ILADLR, ILADLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + FIRSTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + I = 1 +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO ) + FIRSTV = FIRSTV + 1 + I = I + INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILADLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILADLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.GT.0 ) THEN + ! Check if m = 1. This means v = 1, So we just need to compute + ! C := HC = (1-\tau)C. + IF( LASTV.EQ.FIRSTV ) THEN + CALL DSCAL(LASTC, ONE - TAU, C( FIRSTV, 1), LDC) + ELSE +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) +* + ! w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1) + CALL DGEMV( 'Transpose', LASTV-FIRSTV, LASTC, ONE, + $ C(FIRSTV,1), LDC, V(I), INCV, ZERO, + $ WORK, 1) + ! w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) = C(lastv,1:lastc)**T + CALL DAXPY(LASTC, ONE, C(LASTV,1), LDC, WORK, 1) +* +* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T +* + ! C(lastv, 1:lastc) := C(...) - tau * v(lastv,1) * w(1:lastc,1)**T + ! = C(...) - tau * w(1:lastc,1)**T + CALL DAXPY(LASTC, -TAU, WORK, 1, C(LASTV,1), LDC) + ! C(1:lastv-1,1:lastc) := C(...) - tau * v(1:lastv-1,1)*w(1:lastc,1)**T + CALL DGER(LASTV-FIRSTV, LASTC, -TAU, V(I), INCV, + $ WORK, 1, C(FIRSTV,1), LDC) + END IF + END IF + ELSE +* +* Form C * H +* + IF( LASTV.GT.0 ) THEN + ! Check if n = 1. This means v = 1, so we just need to compute + ! C := CH = C(1-\tau). + IF( LASTV.EQ.FIRSTV ) THEN + CALL DSCAL(LASTC, ONE - TAU, C, 1) + ELSE +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + ! w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1) + CALL DGEMV( 'No transpose', LASTC, LASTV-FIRSTV, + $ ONE, C(1,FIRSTV), LDC, V(I), INCV, ZERO, WORK, 1 ) + ! w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) = C(1:lastc,lastv) + CALL DAXPY(LASTC, ONE, C(1,LASTV), 1, WORK, 1) +* +* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T +* + ! C(1:lastc,lastv) := C(...) - tau * w(1:lastc,1) * v(lastv,1)**T + ! = C(...) - tau * w(1:lastc,1) + CALL DAXPY(LASTC, -TAU, WORK, 1, C(1,LASTV), 1) + ! C(1:lastc,1:lastv-1) := C(...) - tau * w(1:lastc,1) * v(1:lastv-1)**T + CALL DGER( LASTC, LASTV-FIRSTV, -TAU, WORK, 1, V(I), + $ INCV, C(1,FIRSTV), LDC ) + END IF + END IF + END IF + RETURN +* +* End of DLARF1L +* + END diff --git a/lapack-netlib/dopmtr.f b/lapack-netlib/dopmtr.f new file mode 100644 index 0000000000..5646b8eacc --- /dev/null +++ b/lapack-netlib/dopmtr.f @@ -0,0 +1,334 @@ +*> \brief \b DOPMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DOPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS, UPLO +* INTEGER INFO, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DOPMTR overwrites the general real M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'T': Q**T * C C * Q**T +*> +*> where Q is a real orthogonal matrix of order nq, with nq = m if +*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +*> nq-1 elementary reflectors, as returned by DSPTRD using packed +*> storage: +*> +*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); +*> +*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left; +*> = 'R': apply Q or Q**T from the Right. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular packed storage used in previous +*> call to DSPTRD; +*> = 'L': Lower triangular packed storage used in previous +*> call to DSPTRD. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'T': Transpose, apply Q**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is DOUBLE PRECISION array, dimension +*> (M*(M+1)/2) if SIDE = 'L' +*> (N*(N+1)/2) if SIDE = 'R' +*> The vectors which define the elementary reflectors, as +*> returned by DSPTRD. AP is modified by the routine but +*> restored on exit. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' +*> or (N-1) if SIDE = 'R' +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DSPTRD. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L' +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup upmtr +* +* ===================================================================== + SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, + $ WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL FORWRD, LEFT, NOTRAN, UPPER + INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + UPPER = LSAME( UPLO, 'U' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DOPMTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Q was determined by a call to DSPTRD with UPLO = 'U' +* + FORWRD = ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) +* + IF( FORWRD ) THEN + I1 = 1 + I2 = NQ - 1 + I3 = 1 + II = 2 + ELSE + I1 = NQ - 1 + I2 = 1 + I3 = -1 + II = NQ*( NQ+1 ) / 2 - 1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(1:i,1:n) +* + MI = I + ELSE +* +* H(i) is applied to C(1:m,1:i) +* + NI = I + END IF +* +* Apply H(i) +* + CALL DLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, + $ LDC, + $ WORK ) +* + IF( FORWRD ) THEN + II = II + I + 2 + ELSE + II = II - I - 1 + END IF + 10 CONTINUE + ELSE +* +* Q was determined by a call to DSPTRD with UPLO = 'L'. +* + FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) +* + IF( FORWRD ) THEN + I1 = 1 + I2 = NQ - 1 + I3 = 1 + II = 2 + ELSE + I1 = NQ - 1 + I2 = 1 + I3 = -1 + II = NQ*( NQ+1 ) / 2 - 1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 20 I = I1, I2, I3 + AII = AP( II ) + AP( II ) = ONE + IF( LEFT ) THEN +* +* H(i) is applied to C(i+1:m,1:n) +* + MI = M - I + IC = I + 1 + ELSE +* +* H(i) is applied to C(1:m,i+1:n) +* + NI = N - I + JC = I + 1 + END IF +* +* Apply H(i) +* + CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), + $ C( IC, JC ), LDC, WORK ) + AP( II ) = AII +* + IF( FORWRD ) THEN + II = II + NQ - I + 1 + ELSE + II = II - NQ + I - 2 + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DOPMTR +* + END diff --git a/lapack-netlib/dorbdb.f b/lapack-netlib/dorbdb.f new file mode 100644 index 0000000000..08be1794a6 --- /dev/null +++ b/lapack-netlib/dorbdb.f @@ -0,0 +1,696 @@ +*> \brief \b DORBDB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, +* X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, +* TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIGNS, TRANS +* INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, +* $ Q +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI( * ), THETA( * ) +* DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), +* $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), +* $ X21( LDX21, * ), X22( LDX22, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORBDB simultaneously bidiagonalizes the blocks of an M-by-M +*> partitioned orthogonal matrix X: +*> +*> [ B11 | B12 0 0 ] +*> [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T +*> X = [-----------] = [---------] [----------------] [---------] . +*> [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ] +*> [ 0 | 0 0 I ] +*> +*> X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is +*> not the case, then X must be transposed and/or permuted. This can be +*> done in constant time using the TRANS and SIGNS options. See DORCSD +*> for details.) +*> +*> The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by- +*> (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are +*> represented implicitly by Householder vectors. +*> +*> B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER +*> = 'T': X, U1, U2, V1T, and V2T are stored in row-major +*> order; +*> otherwise: X, U1, U2, V1T, and V2T are stored in column- +*> major order. +*> \endverbatim +*> +*> \param[in] SIGNS +*> \verbatim +*> SIGNS is CHARACTER +*> = 'O': The lower-left block is made nonpositive (the +*> "other" convention); +*> otherwise: The upper-right block is made nonpositive (the +*> "default" convention). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top-left block of the orthogonal matrix to be +*> reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the columns of tril(X11) specify reflectors for P1, +*> the rows of triu(X11,1) specify reflectors for Q1; +*> else TRANS = 'T', and +*> the rows of triu(X11) specify reflectors for P1, +*> the columns of tril(X11,-1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. If TRANS = 'N', then LDX11 >= +*> P; else LDX11 >= Q. +*> \endverbatim +*> +*> \param[in,out] X12 +*> \verbatim +*> X12 is DOUBLE PRECISION array, dimension (LDX12,M-Q) +*> On entry, the top-right block of the orthogonal matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the rows of triu(X12) specify the first P reflectors for +*> Q2; +*> else TRANS = 'T', and +*> the columns of tril(X12) specify the first P reflectors +*> for Q2. +*> \endverbatim +*> +*> \param[in] LDX12 +*> \verbatim +*> LDX12 is INTEGER +*> The leading dimension of X12. If TRANS = 'N', then LDX12 >= +*> P; else LDX11 >= M-Q. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom-left block of the orthogonal matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the columns of tril(X21) specify reflectors for P2; +*> else TRANS = 'T', and +*> the rows of triu(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. If TRANS = 'N', then LDX21 >= +*> M-P; else LDX21 >= Q. +*> \endverbatim +*> +*> \param[in,out] X22 +*> \verbatim +*> X22 is DOUBLE PRECISION array, dimension (LDX22,M-Q) +*> On entry, the bottom-right block of the orthogonal matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last +*> M-P-Q reflectors for Q2, +*> else TRANS = 'T', and +*> the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last +*> M-P-Q reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX22 +*> \verbatim +*> LDX22 is INTEGER +*> The leading dimension of X22. If TRANS = 'N', then LDX22 >= +*> M-P; else LDX22 >= M-Q. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B12, B21, B22 can +*> be computed from the angles THETA and PHI. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B12, B21, B22 can +*> be computed from the angles THETA and PHI. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] TAUQ2 +*> \verbatim +*> TAUQ2 is DOUBLE PRECISION array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> Q2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The bidiagonal blocks B11, B12, B21, and B22 are represented +*> implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ..., +*> PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are +*> lower bidiagonal. Every entry in each bidiagonal band is a product +*> of a sine or cosine of a THETA with a sine or cosine of a PHI. See +*> [1] or DORCSD for details. +*> +*> P1, P2, Q1, and Q2 are represented as products of elementary +*> reflectors. See DORCSD for details on generating P1, P2, Q1, and Q2 +*> using DORGQR and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, + $ LDX12, + $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, + $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIGNS, TRANS + INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, + $ Q +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI( * ), THETA( * ) + DOUBLE PRECISION TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), + $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), + $ X21( LDX21, * ), X22( LDX22, * ) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION REALONE + PARAMETER ( REALONE = 1.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL COLMAJOR, LQUERY + INTEGER I, LWORKMIN, LWORKOPT + DOUBLE PRECISION Z1, Z2, Z3, Z4 +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARF1F, DLARFGP, DSCAL, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + LOGICAL LSAME + EXTERNAL DNRM2, LSAME +* .. +* .. Intrinsic Functions + INTRINSIC ATAN2, COS, MAX, SIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + COLMAJOR = .NOT. LSAME( TRANS, 'T' ) + IF( .NOT. LSAME( SIGNS, 'O' ) ) THEN + Z1 = REALONE + Z2 = REALONE + Z3 = REALONE + Z4 = REALONE + ELSE + Z1 = REALONE + Z2 = -REALONE + Z3 = REALONE + Z4 = -REALONE + END IF + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -3 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -4 + ELSE IF( Q .LT. 0 .OR. Q .GT. P .OR. Q .GT. M-P .OR. + $ Q .GT. M-Q ) THEN + INFO = -5 + ELSE IF( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -7 + ELSE IF( .NOT.COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -7 + ELSE IF( COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( .NOT.COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -9 + ELSE IF( COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -11 + ELSE IF( .NOT.COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF( COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -13 + ELSE IF( .NOT.COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + LWORKOPT = M - Q + LWORKMIN = M - Q + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN + INFO = -21 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'xORBDB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Handle column-major and row-major separately +* + IF( COLMAJOR ) THEN +* +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* + DO I = 1, Q +* + IF( I .EQ. 1 ) THEN + CALL DSCAL( P-I+1, Z1, X11(I,I), 1 ) + ELSE + CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), 1 ) + CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I, + $ I-1), + $ 1, X11(I,I), 1 ) + END IF + IF( I .EQ. 1 ) THEN + CALL DSCAL( M-P-I+1, Z2, X21(I,I), 1 ) + ELSE + CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), 1 ) + CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I, + $ I-1), + $ 1, X21(I,I), 1 ) + END IF +* + THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), 1 ), + $ DNRM2( P-I+1, X11(I,I), 1 ) ) +* + IF( P .GT. I ) THEN + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, + $ TAUP1(I) ) + ELSE IF( P .EQ. I ) THEN + CALL DLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF + IF ( M-P .GT. I ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, + $ TAUP2(I) ) + END IF +* + IF ( Q .GT. I ) THEN + CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), + $ X11(I,I+1), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ TAUP1(I), + $ X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ TAUP2(I), X21(I,I+1), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ TAUP2(I), X22(I,I), LDX22, WORK ) + END IF +* + IF( I .LT. Q ) THEN + CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I,I+1), + $ LDX11 ) + CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I,I+1), + $ LDX21, + $ X11(I,I+1), LDX11 ) + END IF + CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), + $ LDX12 ) + CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), + $ LDX22, + $ X12(I,I), LDX12 ) +* + IF( I .LT. Q ) + $ PHI(I) = ATAN2( DNRM2( Q-I, X11(I,I+1), LDX11 ), + $ DNRM2( M-Q-I+1, X12(I,I), LDX12 ) ) +* + IF( I .LT. Q ) THEN + IF ( Q-I .EQ. 1 ) THEN + CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL DLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF + END IF + IF ( Q+I-1 .LT. M ) THEN + IF ( M-Q .EQ. I ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF +* + IF( I .LT. Q ) THEN + CALL DLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL DLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) + END IF + IF ( P .GT. I ) THEN + CALL DLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL DLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF +* + END DO +* +* Reduce columns Q + 1, ..., P of X12, X22 +* + DO I = Q + 1, P +* + CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), LDX12 ) + IF ( I .GE. M-Q ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF +* + IF ( P .GT. I ) THEN + CALL DLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF( M-P-Q .GE. 1 ) + $ CALL DLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) +* + END DO +* +* Reduce columns P + 1, ..., M - Q of X12, X22 +* + DO I = 1, M - P - Q +* + CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(Q+I,P+I), LDX22 ) + IF ( I .EQ. M-P-Q ) THEN + CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I) ) + ELSE + CALL DLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), + $ LDX22, TAUQ2(P+I) ) + END IF + IF ( I .LT. M-P-Q ) THEN + CALL DLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), + $ LDX22, + $ TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK ) + END IF +* + END DO +* + ELSE +* +* Reduce columns 1, ..., Q of X11, X12, X21, X22 +* + DO I = 1, Q +* + IF( I .EQ. 1 ) THEN + CALL DSCAL( P-I+1, Z1, X11(I,I), LDX11 ) + ELSE + CALL DSCAL( P-I+1, Z1*COS(PHI(I-1)), X11(I,I), LDX11 ) + CALL DAXPY( P-I+1, -Z1*Z3*Z4*SIN(PHI(I-1)), X12(I-1, + $ I), + $ LDX12, X11(I,I), LDX11 ) + END IF + IF( I .EQ. 1 ) THEN + CALL DSCAL( M-P-I+1, Z2, X21(I,I), LDX21 ) + ELSE + CALL DSCAL( M-P-I+1, Z2*COS(PHI(I-1)), X21(I,I), + $ LDX21 ) + CALL DAXPY( M-P-I+1, -Z2*Z3*Z4*SIN(PHI(I-1)), X22(I-1, + $ I), + $ LDX22, X21(I,I), LDX21 ) + END IF +* + THETA(I) = ATAN2( DNRM2( M-P-I+1, X21(I,I), LDX21 ), + $ DNRM2( P-I+1, X11(I,I), LDX11 ) ) +* + CALL DLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, + $ TAUP1(I) ) + IF ( I .EQ. M-P ) THEN + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + $ TAUP2(I) ) + END IF +* + IF ( Q .GT. I ) THEN + CALL DLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), X12(I,I), LDX12, WORK ) + END IF + IF ( Q .GT. I ) THEN + CALL DLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), + $ X21(I+1,I), LDX21, WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL DLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) + END IF +* + IF( I .LT. Q ) THEN + CALL DSCAL( Q-I, -Z1*Z3*SIN(THETA(I)), X11(I+1,I), 1 ) + CALL DAXPY( Q-I, Z2*Z3*COS(THETA(I)), X21(I+1,I), 1, + $ X11(I+1,I), 1 ) + END IF + CALL DSCAL( M-Q-I+1, -Z1*Z4*SIN(THETA(I)), X12(I,I), 1 ) + CALL DAXPY( M-Q-I+1, Z2*Z4*COS(THETA(I)), X22(I,I), 1, + $ X12(I,I), 1 ) +* + IF( I .LT. Q ) + $ PHI(I) = ATAN2( DNRM2( Q-I, X11(I+1,I), 1 ), + $ DNRM2( M-Q-I+1, X12(I,I), 1 ) ) +* + IF( I .LT. Q ) THEN + IF ( Q-I .EQ. 1) THEN + CALL DLARFGP( Q-I, X11(I+1,I), X11(I+1,I), 1, + $ TAUQ1(I) ) + ELSE + CALL DLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, + $ TAUQ1(I) ) + END IF + END IF + IF ( M-Q .GT. I ) THEN + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) + ELSE + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I,I), 1, + $ TAUQ2(I) ) + END IF +* + IF( I .LT. Q ) THEN + CALL DLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL DLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, + $ TAUQ1(I), X21(I+1,I+1), LDX21, WORK ) + END IF + CALL DLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, TAUQ2(I), + $ X12(I,I+1), LDX12, WORK ) + IF ( M-P-I .GT. 0 ) THEN + CALL DLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ TAUQ2(I), X22(I,I+1), LDX22, WORK ) + END IF +* + END DO +* +* Reduce columns Q + 1, ..., P of X12, X22 +* + DO I = Q + 1, P +* + CALL DSCAL( M-Q-I+1, -Z1*Z4, X12(I,I), 1 ) + CALL DLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) +* + IF ( P .GT. I ) THEN + CALL DLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ TAUQ2(I), X12(I,I+1), LDX12, WORK ) + END IF + IF( M-P-Q .GE. 1 ) + $ CALL DLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, + $ TAUQ2(I), X22(I,Q+1), LDX22, WORK ) +* + END DO +* +* Reduce columns P + 1, ..., M - Q of X12, X22 +* + DO I = 1, M - P - Q +* + CALL DSCAL( M-P-Q-I+1, Z2*Z4, X22(P+I,Q+I), 1 ) + IF ( M-P-Q .EQ. I ) THEN + CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I,Q+I), + $ 1, + $ TAUQ2(P+I) ) + ELSE + CALL DLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), + $ 1, + $ TAUQ2(P+I) ) + CALL DLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), + $ 1, TAUQ2(P+I), X22(P+I,Q+I+1), LDX22, + $ WORK ) + END IF +* + END DO +* + END IF +* + RETURN +* +* End of DORBDB +* + END + diff --git a/lapack-netlib/dorbdb1.f b/lapack-netlib/dorbdb1.f new file mode 100644 index 0000000000..c52293bb68 --- /dev/null +++ b/lapack-netlib/dorbdb1.f @@ -0,0 +1,322 @@ +*> \brief \b DORBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> DORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines DORBDB2, DORBDB3, and DORBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFGP, DORBDB5, DROT, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( X21(I,I), X11(I,I) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), + $ LDX11, WORK(ILARF) ) + CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, + $ S ) + CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, + $ TAUQ1(I) ) + S = X21(I,I+1) + CALL DLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL DLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, + $ TAUQ1(I), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) + C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of DORBDB1 +* + END + diff --git a/lapack-netlib/dorbdb2.f b/lapack-netlib/dorbdb2.f new file mode 100644 index 0000000000..8a5b8d9bae --- /dev/null +++ b/lapack-netlib/dorbdb2.f @@ -0,0 +1,328 @@ +*> \brief \b DORBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P-1) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFGP, DORBDB5, DROT, DSCAL, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, + $ S ) + END IF + CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = X11(I,I) + CALL DLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, + $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) ) + S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DNRM2( M-P-I+1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( X11(I+1,I), X21(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + CALL DLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + CALL DLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I), + $ X21(I,I+1), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB2 +* + END + diff --git a/lapack-netlib/dorbdb3.f b/lapack-netlib/dorbdb3.f new file mode 100644 index 0000000000..855b711a5a --- /dev/null +++ b/lapack-netlib/dorbdb3.f @@ -0,0 +1,330 @@ +*> \brief \b DORBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines DORBDB1, DORBDB2, and DORBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DLARFGP, DORBDB5, DROT, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, + $ S ) + END IF +* + CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = X21(I,I) + CALL DLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL DLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + C = SQRT( DNRM2( P-I+1, X11(I,I), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, + $ TAUP2(I) ) + PHI(I) = ATAN2( X21(I+1,I), X11(I,I) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + CALL DLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + END IF + CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), + $ LDX11, WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL DLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I, + $ I+1), + $ LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB3 +* + END + diff --git a/lapack-netlib/dorbdb4.f b/lapack-netlib/dorbdb4.f new file mode 100644 index 0000000000..6a218fa8ad --- /dev/null +++ b/lapack-netlib/dorbdb4.f @@ -0,0 +1,372 @@ +*> \brief \b DORBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines DORBDB1, DORBDB2, and DORBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is DOUBLE PRECISION array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is DOUBLE PRECISION array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is DOUBLE PRECISION array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is DOUBLE PRECISION array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb4 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or DORCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR +*> and DORGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION NEGONE, ONE, ZERO + PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DNRM2 + EXTERNAL DNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'DORBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL DORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL DSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, + $ TAUP2(1) ) + THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + CALL DLARF1F( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, + $ LDX11, WORK(ILARF) ) + CALL DLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), + $ X21, LDX21, WORK(ILARF) ) + ELSE + CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, + $ TAUP1(I) ) + CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + CALL DLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL DLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ TAUP2(I), X21(I,I), LDX21, WORK(ILARF) ) + END IF +* + CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = X21(I,I) + CALL DLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + IF( I .LT. M-Q ) THEN + S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DNRM2( M-P-I, X21(I+1,I), 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + CALL DLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL DLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), + $ LDX21, + $ TAUQ1(I) ) + CALL DLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, + $ TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + END DO +* + RETURN +* +* End of DORBDB4 +* + END + diff --git a/lapack-netlib/dorg2l.f b/lapack-netlib/dorg2l.f new file mode 100644 index 0000000000..5111fa19ff --- /dev/null +++ b/lapack-netlib/dorg2l.f @@ -0,0 +1,195 @@ +*> \brief \b DORG2L generates all or part of the orthogonal matrix Q from a QL factorization determined by sgeqlf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORG2L generates an m by n real matrix Q with orthonormal columns, +*> which is defined as the last n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by DGEQLF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the (n-k+i)-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQLF in the last k columns of its array +*> argument A. +*> On exit, the m by n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQLF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ung2l +* +* ===================================================================== + SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF1L, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns 1:n-k to columns of the unit matrix +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left +* + !A(M-N+II, II) = ONE + CALL DLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), + $ A, + $ LDA, WORK ) + CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* Set A(m-k+i+1:m,n-k+i) to zero +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2L +* + END diff --git a/lapack-netlib/dorg2r.f b/lapack-netlib/dorg2r.f new file mode 100644 index 0000000000..213a2d54c5 --- /dev/null +++ b/lapack-netlib/dorg2r.f @@ -0,0 +1,195 @@ +*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORG2R generates an m by n real matrix Q with orthonormal columns, +*> which is defined as the first n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by DGEQRF in the first k columns of its array +*> argument A. +*> On exit, the m-by-n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ung2r +* +* ===================================================================== + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2R +* + END diff --git a/lapack-netlib/dorm2l.f b/lapack-netlib/dorm2l.f new file mode 100644 index 0000000000..f86a12f3a6 --- /dev/null +++ b/lapack-netlib/dorm2l.f @@ -0,0 +1,269 @@ +*> \brief \b DORM2L multiplies a general matrix by the orthogonal matrix from a QL factorization determined by sgeqlf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORM2L overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T * C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQLF in the last k columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQLF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unm2l +* +* ===================================================================== + SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF1L, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(1:m-k+i,1:n) +* + MI = M - K + I + ELSE +* +* H(i) is applied to C(1:m,1:n-k+i) +* + NI = N - K + I + END IF +* +* Apply H(i) +* + CALL DLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, + $ WORK ) + 10 CONTINUE + RETURN +* +* End of DORM2L +* + END diff --git a/lapack-netlib/dorm2r.f b/lapack-netlib/dorm2r.f new file mode 100644 index 0000000000..0bda2b1497 --- /dev/null +++ b/lapack-netlib/dorm2r.f @@ -0,0 +1,274 @@ +*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORM2R overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGEQRF in the first k columns of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unm2r +* +* ===================================================================== + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, DLARF1F +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + CALL DLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, + $ JC ), + $ LDC, WORK ) + 10 CONTINUE + RETURN +* +* End of DORM2R +* + END diff --git a/lapack-netlib/dorml2.f b/lapack-netlib/dorml2.f new file mode 100644 index 0000000000..f5f8957b5b --- /dev/null +++ b/lapack-netlib/dorml2.f @@ -0,0 +1,273 @@ +*> \brief \b DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sgelqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download DORML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DORML2 overwrites the general real m by n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**T* C if SIDE = 'L' and TRANS = 'T', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**T if SIDE = 'R' and TRANS = 'T', +*> +*> where Q is a real orthogonal matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**T from the Left +*> = 'R': apply Q or Q**T from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'T': apply Q**T (Transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> DGELQF in the first k rows of its array argument A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by DGELQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unml2 +* +* ===================================================================== + SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLARF1F, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORML2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) +* + CALL DLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), + $ C( IC, JC ), LDC, WORK ) + 10 CONTINUE + RETURN +* +* End of DORML2 +* + END diff --git a/lapack-netlib/zgebd2.f b/lapack-netlib/zgebd2.f new file mode 100644 index 0000000000..465409943a --- /dev/null +++ b/lapack-netlib/zgebd2.f @@ -0,0 +1,321 @@ +*> \brief \b ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGEBD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* DOUBLE PRECISION D( * ), E( * ) +* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEBD2 reduces a complex general m by n matrix A to upper or lower +*> real bidiagonal form B by a unitary transformation: Q**H * A * P = B. +*> +*> If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows in the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns in the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n general matrix to be reduced. +*> On exit, +*> if m >= n, the diagonal and the first superdiagonal are +*> overwritten with the upper bidiagonal matrix B; the +*> elements below the diagonal, with the array TAUQ, represent +*> the unitary matrix Q as a product of elementary +*> reflectors, and the elements above the first superdiagonal, +*> with the array TAUP, represent the unitary matrix P as +*> a product of elementary reflectors; +*> if m < n, the diagonal and the first subdiagonal are +*> overwritten with the lower bidiagonal matrix B; the +*> elements below the first subdiagonal, with the array TAUQ, +*> represent the unitary matrix Q as a product of +*> elementary reflectors, and the elements above the diagonal, +*> with the array TAUP, represent the unitary matrix P as +*> a product of elementary reflectors. +*> See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (min(M,N)) +*> The diagonal elements of the bidiagonal matrix B: +*> D(i) = A(i,i). +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (min(M,N)-1) +*> The off-diagonal elements of the bidiagonal matrix B: +*> if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; +*> if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. +*> \endverbatim +*> +*> \param[out] TAUQ +*> \verbatim +*> TAUQ is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the unitary matrix Q. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP +*> \verbatim +*> TAUP is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors which +*> represent the unitary matrix P. See Further Details. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (max(M,N)) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gebd2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrices Q and P are represented as products of elementary +*> reflectors: +*> +*> If m >= n, +*> +*> Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H +*> +*> where tauq and taup are complex scalars, and v and u are complex +*> vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in +*> A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in +*> A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> If m < n, +*> +*> Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) +*> +*> Each H(i) and G(i) has the form: +*> +*> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H +*> +*> where tauq and taup are complex scalars, v and u are complex vectors; +*> v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); +*> u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); +*> tauq is stored in TAUQ(i) and taup in TAUP(i). +*> +*> The contents of A on exit are illustrated by the following examples: +*> +*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): +*> +*> ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) +*> ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) +*> ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) +*> ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) +*> ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) +*> ( v1 v2 v3 v4 v5 ) +*> +*> where d and e denote diagonal and off-diagonal elements of B, vi +*> denotes an element of the vector defining H(i), and ui an element of +*> the vector defining G(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) + COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. Local Scalars .. + INTEGER I + COMPLEX*16 ALPHA +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1F, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. 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.LT.0 ) THEN + CALL XERBLA( 'ZGEBD2', -INFO ) + RETURN + END IF +* + IF( M.GE.N ) THEN +* +* Reduce to upper bidiagonal form +* + DO 10 I = 1, N +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + ALPHA = A( I, I ) + CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1, + $ TAUQ( I ) ) + D( I ) = DBLE( ALPHA ) +* +* Apply H(i)**H to A(i:m,i+1:n) from the left +* + IF( I.LT.N ) + $ CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ DCONJG( TAUQ( I ) ), A( I, I+1 ), LDA, WORK ) + A( I, I ) = D( I ) +* + IF( I.LT.N ) THEN +* +* Generate elementary reflector G(i) to annihilate +* A(i,i+2:n) +* + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + ALPHA = A( I, I+1 ) + CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA, + $ TAUP( I ) ) + E( I ) = DBLE( ALPHA ) +* +* Apply G(i) to A(i+1:m,i+1:n) from the right +* + CALL ZLARF1F( 'Right', M-I, N-I, A( I, I+1 ), LDA, + $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + A( I, I+1 ) = E( I ) + ELSE + TAUP( I ) = ZERO + END IF + 10 CONTINUE + ELSE +* +* Reduce to lower bidiagonal form +* + DO 20 I = 1, M +* +* Generate elementary reflector G(i) to annihilate A(i,i+1:n) +* + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + ALPHA = A( I, I ) + CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA, + $ TAUP( I ) ) + D( I ) = DBLE( ALPHA ) +* +* Apply G(i) to A(i+1:m,i:n) from the right +* + IF( I.LT.M ) + $ CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAUP( I ), A( I+1, I ), LDA, WORK ) + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + A( I, I ) = D( I ) +* + IF( I.LT.M ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:m,i) +* + ALPHA = A( I+1, I ) + CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1, + $ TAUQ( I ) ) + E( I ) = DBLE( ALPHA ) +* +* Apply H(i)**H to A(i+1:m,i+1:n) from the left +* + CALL ZLARF1F( 'Left', M-I, N-I, A( I+1, I ), 1, + $ DCONJG( TAUQ( I ) ), A( I+1, I+1 ), LDA, + $ WORK ) + A( I+1, I ) = E( I ) + ELSE + TAUQ( I ) = ZERO + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZGEBD2 +* + END diff --git a/lapack-netlib/zgehd2.f b/lapack-netlib/zgehd2.f new file mode 100644 index 0000000000..4250de42b5 --- /dev/null +++ b/lapack-netlib/zgehd2.f @@ -0,0 +1,217 @@ +*> \brief \b ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGEHD2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H +*> by a unitary similarity transformation: Q**H * A * Q = H . +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] ILO +*> \verbatim +*> ILO is INTEGER +*> \endverbatim +*> +*> \param[in] IHI +*> \verbatim +*> IHI is INTEGER +*> +*> It is assumed that A is already upper triangular in rows +*> and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally +*> set by a previous call to ZGEBAL; otherwise they should be +*> set to 1 and N respectively. See Further Details. +*> 1 <= ILO <= IHI <= max(1,N). +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the n by n general matrix to be reduced. +*> On exit, the upper triangle and the first subdiagonal of A +*> are overwritten with the upper Hessenberg matrix H, and the +*> elements below the first subdiagonal, with the array TAU, +*> represent the unitary matrix Q as a product of elementary +*> reflectors. See Further Details. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (N-1) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gehd2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of (ihi-ilo) elementary +*> reflectors +*> +*> Q = H(ilo) H(ilo+1) . . . H(ihi-1). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on +*> exit in A(i+2:ihi,i), and tau in TAU(i). +*> +*> The contents of A are illustrated by the following example, with +*> n = 7, ilo = 2 and ihi = 6: +*> +*> on entry, on exit, +*> +*> ( a a a a a a a ) ( a a h h h h a ) +*> ( a a a a a a ) ( a h h h h a ) +*> ( a a a a a a ) ( h h h h h h ) +*> ( a a a a a a ) ( v2 h h h h h ) +*> ( a a a a a a ) ( v2 v3 h h h h ) +*> ( a a a a a a ) ( v2 v3 v4 h h h ) +*> ( a ) ( a ) +*> +*> where a denotes an element of the original matrix A, h denotes a +*> modified element of the upper Hessenberg matrix H, and vi denotes an +*> element of the vector defining H(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, INFO, LDA, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1F, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN + INFO = -2 + ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEHD2', -INFO ) + RETURN + END IF +* + DO 10 I = ILO, IHI - 1 +* +* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) +* + CALL ZLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) +* +* Apply H(i) to A(1:ihi,i+1:ihi) from the right +* + CALL ZLARF1F( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ), + $ A( 1, I+1 ), LDA, WORK ) +* +* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left +* + CALL ZLARF1F( 'Left', IHI-I, N-I, A( I+1, I ), 1, + $ CONJG( TAU( I ) ), A( I+1, I+1 ), LDA, WORK ) +* + 10 CONTINUE +* + RETURN +* +* End of ZGEHD2 +* + END diff --git a/lapack-netlib/zgelq2.f b/lapack-netlib/zgelq2.f new file mode 100644 index 0000000000..19bac3142d --- /dev/null +++ b/lapack-netlib/zgelq2.f @@ -0,0 +1,195 @@ +*> \brief \b ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGELQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGELQ2 computes an LQ factorization of a complex m-by-n matrix A: +*> +*> A = ( L 0 ) * Q +*> +*> where: +*> +*> Q is a n-by-n orthogonal matrix; +*> L is a lower-triangular m-by-m matrix; +*> 0 is a m-by-(n-m) zero matrix, if m < n. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and below the diagonal of the array +*> contain the m by min(m,n) lower trapezoidal matrix L (L is +*> lower triangular if m <= n); the elements above the diagonal, +*> with the array TAU, represent the unitary matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gelq2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k)**H . . . H(2)**H H(1)**H, where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in +*> A(i,i+1:n), and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1F, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'ZGELQ2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i,i+1:n) +* + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + CALL ZLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, + $ TAU( I ) ) + IF( I.LT.M ) THEN +* +* Apply H(i) to A(i+1:m,i:n) from the right +* + CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ TAU( I ), + $ A( I+1, I ), LDA, WORK ) + END IF + CALL ZLACGV( N-I+1, A( I, I ), LDA ) + 10 CONTINUE + RETURN +* +* End of ZGELQ2 +* + END diff --git a/lapack-netlib/zgeql2.f b/lapack-netlib/zgeql2.f new file mode 100644 index 0000000000..6cd9afe8cb --- /dev/null +++ b/lapack-netlib/zgeql2.f @@ -0,0 +1,185 @@ +*> \brief \b ZGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGEQL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEQL2 computes a QL factorization of a complex m by n matrix A: +*> A = Q * L. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, if m >= n, the lower triangle of the subarray +*> A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; +*> if m <= n, the elements on and below the (n-m)-th +*> superdiagonal contain the m by n lower trapezoidal matrix L; +*> the remaining elements, with the array TAU, represent the +*> unitary matrix Q as a product of elementary reflectors +*> (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geql2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in +*> A(1:m-k+i-1,n-k+i), and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1L, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'ZGEQL2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = K, 1, -1 +* +* Generate elementary reflector H(i) to annihilate +* A(1:m-k+i-1,n-k+i) +* + CALL ZLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1, + $ TAU( I ) ) +* +* Apply H(i)**H to A(1:m-k+i,1:n-k+i-1) from the left +* + CALL ZLARF1L( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, + $ CONJG( TAU( I ) ), A, LDA, WORK ) + 10 CONTINUE + RETURN +* +* End of ZGEQL2 +* + END diff --git a/lapack-netlib/zgeqp3rk.f b/lapack-netlib/zgeqp3rk.f new file mode 100644 index 0000000000..989ce69cc7 --- /dev/null +++ b/lapack-netlib/zgeqp3rk.f @@ -0,0 +1,1084 @@ +*> \brief \b ZGEQP3RK computes a truncated Householder QR factorization with column pivoting of a complex m-by-n matrix A by using Level 3 BLAS and overwrites m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGEQP3RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, +* $ WORK, LWORK, RWORK, IWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, K, KMAX, LDA, LWORK, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ), JPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEQP3RK performs two tasks simultaneously: +*> +*> Task 1: The routine computes a truncated (rank K) or full rank +*> Householder QR factorization with column pivoting of a complex +*> M-by-N matrix A using Level 3 BLAS. K is the number of columns +*> that were factorized, i.e. factorization rank of the +*> factor R, K <= min(M,N). +*> +*> A * P(K) = Q(K) * R(K) = +*> +*> = Q(K) * ( R11(K) R12(K) ) = Q(K) * ( R(K)_approx ) +*> ( 0 R22(K) ) ( 0 R(K)_residual ), +*> +*> where: +*> +*> P(K) is an N-by-N permutation matrix; +*> Q(K) is an M-by-M unitary matrix; +*> R(K)_approx = ( R11(K), R12(K) ) is a rank K approximation of the +*> full rank factor R with K-by-K upper-triangular +*> R11(K) and K-by-N rectangular R12(K). The diagonal +*> entries of R11(K) appear in non-increasing order +*> of absolute value, and absolute values of all of +*> them exceed the maximum column 2-norm of R22(K) +*> up to roundoff error. +*> R(K)_residual = R22(K) is the residual of a rank K approximation +*> of the full rank factor R. It is a +*> an (M-K)-by-(N-K) rectangular matrix; +*> 0 is a an (M-K)-by-K zero matrix. +*> +*> Task 2: At the same time, the routine overwrites a complex M-by-NRHS +*> matrix B with Q(K)**H * B using Level 3 BLAS. +*> +*> ===================================================================== +*> +*> The matrices A and B are stored on input in the array A as +*> the left and right blocks A(1:M,1:N) and A(1:M, N+1:N+NRHS) +*> respectively. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> The truncation criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) The input parameter KMAX, the maximum number of columns +*> KMAX to factorize, i.e. the factorization rank is limited +*> to KMAX. If KMAX >= min(M,N), the criterion is not used. +*> +*> 2) The input parameter ABSTOL, the absolute tolerance for +*> the maximum column 2-norm of the residual matrix R22(K). This +*> means that the factorization stops if this norm is less or +*> equal to ABSTOL. If ABSTOL < 0.0, the criterion is not used. +*> +*> 3) The input parameter RELTOL, the tolerance for the maximum +*> column 2-norm matrix of the residual matrix R22(K) divided +*> by the maximum column 2-norm of the original matrix A, which +*> is equal to abs(R(1,1)). This means that the factorization stops +*> when the ratio of the maximum column 2-norm of R22(K) to +*> the maximum column 2-norm of A is less than or equal to RELTOL. +*> If RELTOL < 0.0, the criterion is not used. +*> +*> 4) In case both stopping criteria ABSTOL or RELTOL are not used, +*> and when the residual matrix R22(K) is a zero matrix in some +*> factorization step K. ( This stopping criterion is implicit. ) +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the whole matrix A is factorized. +*> +*> To factorize the whole matrix A, use the values +*> KMAX >= min(M,N), ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> The routine returns: +*> a) Q(K), R(K)_approx = ( R11(K), R12(K) ), +*> R(K)_residual = R22(K), P(K), i.e. the resulting matrices +*> of the factorization; P(K) is represented by JPIV, +*> ( if K = min(M,N), R(K)_approx is the full factor R, +*> and there is no residual matrix R(K)_residual); +*> b) K, the number of columns that were factorized, +*> i.e. factorization rank; +*> c) MAXC2NRMK, the maximum column 2-norm of the residual +*> matrix R(K)_residual = R22(K), +*> ( if K = min(M,N), MAXC2NRMK = 0.0 ); +*> d) RELMAXC2NRMK equals MAXC2NRMK divided by MAXC2NRM, the maximum +*> column 2-norm of the original matrix A, which is equal +*> to abs(R(1,1)), ( if K = min(M,N), RELMAXC2NRMK = 0.0 ); +*> e) Q(K)**H * B, the matrix B with the unitary +*> transformation Q(K)**H applied on the left. +*> +*> The N-by-N permutation matrix P(K) is stored in a compact form in +*> the integer array JPIV. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The M-by-M unitary matrix Q is represented as a product +*> of elementary Householder reflectors +*> +*> Q(K) = H(1) * H(2) * . . . * H(K), +*> +*> where K is the number of columns that were factorized. +*> +*> Each H(j) has the form +*> +*> H(j) = I - tau * v * v**H, +*> +*> where 1 <= j <= K and +*> I is an M-by-M identity matrix, +*> tau is a complex scalar, +*> v is a complex vector with v(1:j-1) = 0 and v(j) = 1. +*> +*> v(j+1:M) is stored on exit in A(j+1:M,j) and tau in TAU(j). +*> +*> See the Further Details section for more information. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e. the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M,N), then this stopping criterion +*> is not used, the routine factorizes columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B are not modified, and +*> the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION +*> +*> The second factorization stopping criterion, cannot be NaN. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix R22(K). +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix R22(K) +*> is less than or equal to ABSTOL. Let SAFMIN = DLAMCH('S'). +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -5 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If ABSTOL chosen above is >= MAXC2NRM, then this +*> stopping criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. The routine +*> returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case ABSTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION +*> +*> The third factorization stopping criterion, cannot be NaN. +*> +*> The tolerance (stopping threshold) for the ratio +*> abs(R(K+1,K+1))/abs(R(1,1)) of the maximum column 2-norm of +*> the residual matrix R22(K) to the maximum column 2-norm of +*> the original matrix A. The algorithm converges (stops the +*> factorization), when abs(R(K+1,K+1))/abs(R(1,1)) A is less +*> than or equal to RELTOL. Let EPS = DLAMCH('E'). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -6 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> Let MAXC2NRM be the maximum column 2-norm of the +*> whole original matrix A. +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input and routine exits +*> immediately after MAXC2NRM is computed. +*> The routine returns MAXC2NRM in MAXC2NORMK, +*> and 1.0 in RELMAXC2NORMK. +*> This includes the case RELTOL = +Inf. This means that the +*> factorization is not performed, the matrices A and B are not +*> modified, and the matrix A is itself the residual. +*> +*> NOTE: We recommend that RELTOL satisfy +*> min( 10*max(M,N)*EPS, sqrt(EPS) ) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> +*> On entry: +*> +*> a) The subarray A(1:M,1:N) contains the M-by-N matrix A. +*> b) The subarray A(1:M,N+1:N+NRHS) contains the M-by-NRHS +*> matrix B. +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> +*> a) The subarray A(1:M,1:N) contains parts of the factors +*> of the matrix A: +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> 2) If K > 0, A(1:M,1:N) contains parts of the +*> factors: +*> +*> 1. The elements below the diagonal of the subarray +*> A(1:M,1:K) together with TAU(1:K) represent the +*> unitary matrix Q(K) as a product of K Householder +*> elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A(1:K,1:N) contain K-by-N +*> upper-trapezoidal matrix +*> R(K)_approx = ( R11(K), R12(K) ). +*> NOTE: If K=min(M,N), i.e. full rank factorization, +*> then R_approx(K) is the full factor R which +*> is upper-trapezoidal. If, in addition, M>=N, +*> then R is upper-triangular. +*> +*> 3. The subarray A(K+1:M,K+1:N) contains (M-K)-by-(N-K) +*> rectangular matrix R(K)_residual = R22(K). +*> +*> b) If NRHS > 0, the subarray A(1:M,N+1:N+NRHS) contains +*> the M-by-NRHS product Q(K)**H * B. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> This is the leading dimension for both matrices, A and B. +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> +*> NOTE: If K = 0, a) the arrays A and B are not modified; +*> b) the array TAU(1:min(M,N)) is set to ZERO, +*> if the matrix A does not contain NaN, +*> otherwise the elements TAU(1:min(M,N)) +*> are undefined; +*> c) the elements of the array JPIV are set +*> as follows: for j = 1:N, JPIV(j) = j. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix R22(K), +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then MAXC2NRMK equals the maximum column 2-norm +*> of the original matrix A. +*> +*> b) If 0 < K < min(M,N), then MAXC2NRMK is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK in the factorization step K would equal +*> R(K+1,K+1) in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix R22(K) (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A was not modified and is itself a residual +*> matrix, then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M,N), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M,N), i.e. the whole matrix A was +*> factorized and there is no residual matrix, +*> then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK in the factorization step K would equal +*> abs(R(K+1,K+1))/abs(R(1,1)) in the next factorization +*> step K+1. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices. For 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> +*> The elements of the array JPIV(1:N) are always set +*> by the routine, for example, even when no columns +*> were factorized, i.e. when K = 0, the elements are +*> set as JPIV(j) = j for j = 1:N. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> +*> If 0 < K <= min(M,N), only the elements TAU(1:K) of +*> the array TAU are modified by the factorization. +*> After the factorization computed, if no NaN was found +*> during the factorization, the remaining elements +*> TAU(K+1:min(M,N)) are set to zero, otherwise the +*> elements TAU(K+1:min(M,N)) are not set and therefore +*> undefined. +*> ( If K = 0, all elements of TAU are set to zero, if +*> the matrix A does not contain NaN. ) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> LWORK >= 1, if MIN(M,N) = 0, and +*> LWORK >= N+NRHS-1, otherwise. +*> For optimal performance LWORK >= NB*( N+NRHS+1 ), +*> where NB is the optimal block size for ZGEQP3RK returned +*> by ILAENV. Minimal block size MINNB=2. +*> +*> NOTE: The decision, whether to use unblocked BLAS 2 +*> or blocked BLAS 3 code is based not only on the dimension +*> LWORK of the availbale workspace WORK, but also also on the +*> matrix A dimension N via crossover point NX returned +*> by ILAENV. (For N less than NX, unblocked code should be +*> used.) +*> +*> If LWORK = -1, then a workspace query is assumed; +*> the routine only calculates the optimal size of the WORK +*> array, returns this value as the first entry of the WORK +*> array, and no error message related to LWORK is issued +*> by XERBLA. +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (2*N) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (N-1). +*> Is a work array. ( IWORK is used to store indices +*> of "bad" columns for norm downdating in the residual +*> matrix in the blocked step auxiliary subroutine ZLAQP3RK ). +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) INFO < 0: if INFO = -i, the i-th argument had an +*> illegal value. +*> 3) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 4) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqp3rk +* +*> \par Further Details: +* ===================== +* +*> \verbatim +*> ZGEQP3RK is based on the same BLAS3 Householder QR factorization +*> algorithm with column pivoting as in ZGEQP3 routine which uses +*> ZLARFG routine to generate Householder reflectors +*> for QR factorization. +*> +*> We can also write: +*> +*> A = A_approx(K) + A_residual(K) +*> +*> The low rank approximation matrix A(K)_approx from +*> the truncated QR factorization of rank K of the matrix A is: +*> +*> A(K)_approx = Q(K) * ( R(K)_approx ) * P(K)**T +*> ( 0 0 ) +*> +*> = Q(K) * ( R11(K) R12(K) ) * P(K)**T +*> ( 0 0 ) +*> +*> The residual A_residual(K) of the matrix A is: +*> +*> A_residual(K) = Q(K) * ( 0 0 ) * P(K)**T = +*> ( 0 R(K)_residual ) +*> +*> = Q(K) * ( 0 0 ) * P(K)**T +*> ( 0 R22(K) ) +*> +*> The truncated (rank K) factorization guarantees that +*> the maximum column 2-norm of A_residual(K) is less than +*> or equal to MAXC2NRMK up to roundoff error. +*> +*> NOTE: An approximation of the null vectors +*> of A can be easily computed from R11(K) +*> and R12(K): +*> +*> Null( A(K) )_approx = P * ( inv(R11(K)) * R12(K) ) +*> ( -I ) +*> +*> \endverbatim +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> https://doi.org/10.1137/S1064827595296732 +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> https://doi.org/10.1145/1377612.1377616 +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZGEQP3RK( M, N, NRHS, KMAX, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, JPIV, TAU, + $ WORK, LWORK, RWORK, IWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, KF, KMAX, LDA, LWORK, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRMK, RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER IWORK( * ), JPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER INB, INBMIN, IXOVER + PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 ) + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, DONE + INTEGER IINFO, IOFFSET, IWS, J, JB, JBF, JMAXB, JMAX, + $ JMAXC2NRM, KP1, LWKOPT, MINMN, N_SUB, NB, + $ NBMIN, NX + DOUBLE PRECISION EPS, HUGEVAL, MAXC2NRM, SAFMIN +* .. +* .. External Subroutines .. + EXTERNAL ZLAQP2RK, ZLAQP3RK, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, DZNRM2, IDAMAX, ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test input arguments +* ==================== +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( KMAX.LT.0 ) THEN + INFO = -4 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -5 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -6 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -8 + END IF +* +* If the input parameters M, N, NRHS, KMAX, LDA are valid: +* a) Test the input workspace size LWORK for the minimum +* size requirement IWS. +* b) Determine the optimal block size NB and optimal +* workspace size LWKOPT to be returned in WORK(1) +* in case of (1) LWORK < IWS, (2) LQUERY = .TRUE., +* (3) when routine exits. +* Here, IWS is the miminum workspace required for unblocked +* code. +* + IF( INFO.EQ.0 ) THEN + MINMN = MIN( M, N ) + IF( MINMN.EQ.0 ) THEN + IWS = 1 + LWKOPT = 1 + ELSE +* +* Minimal workspace size in case of using only unblocked +* BLAS 2 code in ZLAQP2RK. +* 1) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in ZLARF1F subroutine inside ZLAQP2RK to apply an +* elementary reflector from the left. +* TOTAL_WORK_SIZE = 3*N + NRHS - 1 +* + IWS = N + NRHS - 1 +* +* Assign to NB optimal block size. +* + NB = ILAENV( INB, 'ZGEQP3RK', ' ', M, N, -1, -1 ) +* +* A formula for the optimal workspace size in case of using +* both unblocked BLAS 2 in ZLAQP2RK and blocked BLAS 3 code +* in ZLAQP3RK. +* 1) ZGEQP3RK, ZLAQP2RK, ZLAQP3RK: 2*N to store full and +* partial column 2-norms. +* 2) ZLAQP2RK: N+NRHS-1 to use in WORK array that is used +* in ZLARF1F subroutine to apply an elementary reflector +* from the left. +* 3) ZLAQP3RK: NB*(N+NRHS) to use in the work array F that +* is used to apply a block reflector from +* the left. +* 4) ZLAQP3RK: NB to use in the auxilixary array AUX. +* Sizes (2) and ((3) + (4)) should intersect, therefore +* TOTAL_WORK_SIZE = 2*N + NB*( N+NRHS+1 ), given NBMIN=2. +* + LWKOPT = 2*N + NB*( N+NRHS+1 ) + END IF + WORK( 1 ) = DCMPLX( LWKOPT ) +* + IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN + INFO = -15 + END IF + END IF +* +* NOTE: The optimal workspace size is returned in WORK(1), if +* the input parameters M, N, NRHS, KMAX, LDA are valid. +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGEQP3RK', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible for M=0 or N=0. +* + IF( MINMN.EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* +* Initialize column pivot array JPIV. +* + DO J = 1, N + JPIV( J ) = J + END DO +* +* ================================================================== +* +* Initialize storage for partial and exact column 2-norms. +* a) The elements WORK(1:N) are used to store partial column +* 2-norms of the matrix A, and may decrease in each computation +* step; initialize to the values of complete columns 2-norms. +* b) The elements WORK(N+1:2*N) are used to store complete column +* 2-norms of the matrix A, they are not changed during the +* computation; initialize the values of complete columns 2-norms. +* + DO J = 1, N + RWORK( J ) = DZNRM2( M, A( 1, J ), 1 ) + RWORK( N+J ) = RWORK( J ) + END DO +* +* ================================================================== +* +* Compute the pivot column index and the maximum column 2-norm +* for the whole original matrix stored in A(1:M,1:N). +* + KP1 = IDAMAX( N, RWORK( 1 ), 1 ) + MAXC2NRM = RWORK( KP1 ) +* +* ==================================================================. +* + IF( DISNAN( MAXC2NRM ) ) THEN +* +* Check if the matrix A contains NaN, set INFO parameter +* to the column number where the first NaN is found and return +* from the routine. +* + K = 0 + INFO = KP1 +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = MAXC2NRM +* +* Array TAU is not set and contains undefined elements. +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* =================================================================== +* + IF( MAXC2NRM.EQ.ZERO ) THEN +* +* Check is the matrix A is a zero matrix, set array TAU and +* return from the routine. +* + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN +* + END IF +* +* =================================================================== +* + HUGEVAL = DLAMCH( 'Overflow' ) +* + IF( MAXC2NRM.GT.HUGEVAL ) THEN +* +* Check if the matrix A contains +Inf or -Inf, set INFO parameter +* to the column number, where the first +/-Inf is found plus N, +* and continue the computation. +* + INFO = N + KP1 +* + END IF +* +* ================================================================== +* +* Quick return if possible for the case when the first +* stopping criterion is satisfied, i.e. KMAX = 0. +* + IF( KMAX.EQ.0 ) THEN + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE + DO J = 1, MINMN + TAU( J ) = CZERO + END DO + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* +* Adjust ABSTOL +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + END IF +* +* Adjust RELTOL +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + END IF +* +* =================================================================== +* +* JMAX is the maximum index of the column to be factorized, +* which is also limited by the first stopping criterion KMAX. +* + JMAX = MIN( KMAX, MINMN ) +* +* =================================================================== +* +* Quick return if possible for the case when the second or third +* stopping criterion for the whole original matrix is satified, +* i.e. MAXC2NRM <= ABSTOL or RELMAXC2NRM <= RELTOL +* (which is ONE <= RELTOL). +* + IF( MAXC2NRM.LE.ABSTOL .OR. ONE.LE.RELTOL ) THEN +* + K = 0 + MAXC2NRMK = MAXC2NRM + RELMAXC2NRMK = ONE +* + DO J = 1, MINMN + TAU( J ) = CZERO + END DO +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RETURN + END IF +* +* ================================================================== +* Factorize columns +* ================================================================== +* +* Determine the block size. +* + NBMIN = 2 + NX = 0 +* + IF( ( NB.GT.1 ) .AND. ( NB.LT.MINMN ) ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* (for N less than NX, unblocked code should be used). +* + NX = MAX( 0, ILAENV( IXOVER, 'ZGEQP3RK', ' ', M, N, -1, + $ -1 ) ) +* + IF( NX.LT.MINMN ) THEN +* +* Determine if workspace is large enough for blocked code. +* + IF( LWORK.LT.LWKOPT ) THEN +* +* Not enough workspace to use optimal block size that +* is currently stored in NB. +* Reduce NB and determine the minimum value of NB. +* + NB = ( LWORK-2*N ) / ( N+1 ) + NBMIN = MAX( 2, ILAENV( INBMIN, 'ZGEQP3RK', ' ', M, N, + $ -1, -1 ) ) +* + END IF + END IF + END IF +* +* ================================================================== +* +* DONE is the boolean flag to rerpresent the case when the +* factorization completed in the block factorization routine, +* before the end of the block. +* + DONE = .FALSE. +* +* J is the column index. +* + J = 1 +* +* (1) Use blocked code initially. +* +* JMAXB is the maximum column index of the block, when the +* blocked code is used, is also limited by the first stopping +* criterion KMAX. +* + JMAXB = MIN( KMAX, MINMN - NX ) +* + IF( NB.GE.NBMIN .AND. NB.LT.JMAX .AND. JMAXB.GT.0 ) THEN +* +* Loop over the column blocks of the matrix A(1:M,1:JMAXB). Here: +* J is the column index of a column block; +* JB is the column block size to pass to block factorization +* routine in a loop step; +* JBF is the number of columns that were actually factorized +* that was returned by the block factorization routine +* in a loop step, JBF <= JB; +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + DO WHILE( J.LE.JMAXB ) +* + JB = MIN( NB, JMAXB-J+1 ) + N_SUB = N-J+1 + IOFFSET = J-1 +* +* Factorize JB columns among the columns A(J:N). +* + CALL ZLAQP3RK( M, N_SUB, NRHS, IOFFSET, JB, ABSTOL, + $ RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ DONE, JBF, MAXC2NRMK, RELMAXC2NRMK, + $ JPIV( J ), TAU( J ), + $ RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), WORK( JB+1 ), + $ N+NRHS-J+1, IWORK, IINFO ) +* +* Set INFO on the first occurence of Inf. +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + END IF +* + IF( DONE ) THEN +* +* Either the submatrix is zero before the end of the +* column block, or ABSTOL or RELTOL criterion is +* satisfied before the end of the column block, we can +* return from the routine. Perform the following before +* returning: +* a) Set the number of factorized columns K, +* K = IOFFSET + JBF from the last call of blocked +* routine. +* NOTE: 1) MAXC2NRMK and RELMAXC2NRMK are returned +* by the block factorization routine; +* 2) The remaining TAUs are set to ZERO by the +* block factorization routine. +* + K = IOFFSET + JBF +* +* Set INFO on the first occurrence of NaN, NaN takes +* prcedence over Inf. +* + IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* +* Return from the routine. +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* + END IF +* + J = J + JBF +* + END DO +* + END IF +* +* Use unblocked code to factor the last or only block. +* J = JMAX+1 means we factorized the maximum possible number of +* columns, that is in ELSE clause we need to compute +* the MAXC2NORM and RELMAXC2NORM to return after we processed +* the blocks. +* + IF( J.LE.JMAX ) THEN +* +* N_SUB is the number of columns in the submatrix; +* IOFFSET is the number of rows that should not be factorized. +* + N_SUB = N-J+1 + IOFFSET = J-1 +* + CALL ZLAQP2RK( M, N_SUB, NRHS, IOFFSET, JMAX-J+1, + $ ABSTOL, RELTOL, KP1, MAXC2NRM, A( 1, J ), LDA, + $ KF, MAXC2NRMK, RELMAXC2NRMK, JPIV( J ), + $ TAU( J ), RWORK( J ), RWORK( N+J ), + $ WORK( 1 ), IINFO ) +* +* ABSTOL or RELTOL criterion is satisfied when the number of +* the factorized columns KF is smaller then the number +* of columns JMAX-J+1 supplied to be factorized by the +* unblocked routine, we can return from +* the routine. Perform the following before returning: +* a) Set the number of factorized columns K, +* b) MAXC2NRMK and RELMAXC2NRMK are returned by the +* unblocked factorization routine above. +* + K = J - 1 + KF +* +* Set INFO on the first exception occurence. +* +* Set INFO on the first exception occurence of Inf or NaN, +* (NaN takes precedence over Inf). +* + IF( IINFO.GT.N_SUB .AND. INFO.EQ.0 ) THEN + INFO = 2*IOFFSET + IINFO + ELSE IF( IINFO.LE.N_SUB .AND. IINFO.GT.0 ) THEN + INFO = IOFFSET + IINFO + END IF +* + ELSE +* +* Compute the return values for blocked code. +* +* Set the number of factorized columns if the unblocked routine +* was not called. +* + K = JMAX +* +* If there exits a residual matrix after the blocked code: +* 1) compute the values of MAXC2NRMK, RELMAXC2NRMK of the +* residual matrix, otherwise set them to ZERO; +* 2) Set TAU(K+1:MINMN) to ZERO. +* + IF( K.LT.MINMN ) THEN + JMAXC2NRM = K + IDAMAX( N-K, RWORK( K+1 ), 1 ) + MAXC2NRMK = RWORK( JMAXC2NRM ) + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + DO J = K + 1, MINMN + TAU( J ) = CZERO + END DO +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* END IF( J.LE.JMAX ) THEN +* + END IF +* + WORK( 1 ) = DCMPLX( LWKOPT ) +* + RETURN +* +* End of ZGEQP3RK +* + END diff --git a/lapack-netlib/zgeqr2.f b/lapack-netlib/zgeqr2.f new file mode 100644 index 0000000000..958e606b73 --- /dev/null +++ b/lapack-netlib/zgeqr2.f @@ -0,0 +1,193 @@ +*> \brief \b ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGEQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEQR2 computes a QR factorization of a complex m-by-n matrix A: +*> +*> A = Q * ( R ), +*> ( 0 ) +*> +*> where: +*> +*> Q is a m-by-m orthogonal matrix; +*> R is an upper-triangular n-by-n matrix; +*> 0 is a (m-n)-by-n zero matrix, if m > n. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(m,n) by n upper trapezoidal matrix R (R is +*> upper triangular if m >= n); the elements below the diagonal, +*> with the array TAU, represent the unitary matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqr2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1F, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'ZGEQR2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL ZLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i)**H to A(i:m,i+1:n) from the left +* + CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) + END IF + 10 CONTINUE + RETURN +* +* End of ZGEQR2 +* + END diff --git a/lapack-netlib/zgeqr2p.f b/lapack-netlib/zgeqr2p.f new file mode 100644 index 0000000000..aef5a2b015 --- /dev/null +++ b/lapack-netlib/zgeqr2p.f @@ -0,0 +1,197 @@ +*> \brief \b ZGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elements using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGEQR2P + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEQR2P computes a QR factorization of a complex m-by-n matrix A: +*> +*> A = Q * ( R ), +*> ( 0 ) +*> +*> where: +*> +*> Q is a m-by-m orthogonal matrix; +*> R is an upper-triangular n-by-n matrix with nonnegative diagonal +*> entries; +*> 0 is a (m-n)-by-n zero matrix, if m > n. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, the elements on and above the diagonal of the array +*> contain the min(m,n) by n upper trapezoidal matrix R (R is +*> upper triangular if m >= n). The diagonal entries of R +*> are real and nonnegative; the elements below the diagonal, +*> with the array TAU, represent the unitary matrix Q as a +*> product of elementary reflectors (see Further Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup geqr2p +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k), where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), +*> and tau in TAU(i). +*> +*> See Lapack Working Note 203 for details +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1F, ZLARFGP +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'ZGEQR2P', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = 1, K +* +* Generate elementary reflector H(i) to annihilate A(i+1:m,i) +* + CALL ZLARFGP( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, + $ TAU( I ) ) + IF( I.LT.N ) THEN +* +* Apply H(i)**H to A(i:m,i+1:n) from the left +* + CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, + $ CONJG( TAU( I ) ), A( I, I+1 ), LDA, WORK ) + END IF + 10 CONTINUE + RETURN +* +* End of ZGEQR2P +* + END diff --git a/lapack-netlib/zgerq2.f b/lapack-netlib/zgerq2.f new file mode 100644 index 0000000000..dbd33d6b16 --- /dev/null +++ b/lapack-netlib/zgerq2.f @@ -0,0 +1,187 @@ +*> \brief \b ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZGERQ2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGERQ2 computes an RQ factorization of a complex m by n matrix A: +*> A = R * Q. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the m by n matrix A. +*> On exit, if m <= n, the upper triangle of the subarray +*> A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; +*> if m >= n, the elements on and above the (m-n)-th subdiagonal +*> contain the m by n upper trapezoidal matrix R; the remaining +*> elements, with the array TAU, represent the unitary matrix +*> Q as a product of elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors (see Further +*> Details). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup gerq2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The matrix Q is represented as a product of elementary reflectors +*> +*> Q = H(1)**H H(2)**H . . . H(k)**H, where k = min(m,n). +*> +*> Each H(i) has the form +*> +*> H(i) = I - tau * v * v**H +*> +*> where tau is a complex scalar, and v is a complex vector with +*> v(n-k+i+1:n) = 0 and v(n-k+i) = 1; conjg(v(1:n-k+i-1)) is stored on +*> exit in A(m-k+i,1:n-k+i-1), and tau in TAU(i). +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGERQ2( M, N, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, K +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1L, ZLARFG +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + 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( 'ZGERQ2', -INFO ) + RETURN + END IF +* + K = MIN( M, N ) +* + DO 10 I = K, 1, -1 +* +* Generate elementary reflector H(i) to annihilate +* A(m-k+i,1:n-k+i-1) +* + CALL ZLACGV( N-K+I, A( M-K+I, 1 ), LDA ) + CALL ZLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA, + $ TAU( I ) ) +* +* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right +* + CALL ZLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA, + $ TAU( I ), A, LDA, WORK ) + CALL ZLACGV( N-K+I-1, A( M-K+I, 1 ), LDA ) + 10 CONTINUE + RETURN +* +* End of ZGERQ2 +* + END diff --git a/lapack-netlib/zlaqp2.f b/lapack-netlib/zlaqp2.f new file mode 100644 index 0000000000..bc81b28c26 --- /dev/null +++ b/lapack-netlib/zlaqp2.f @@ -0,0 +1,257 @@ +*> \brief \b ZLAQP2 computes a QR factorization with column pivoting of the matrix block. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZLAQP2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, +* WORK ) +* +* .. Scalar Arguments .. +* INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. +* INTEGER JPVT( * ) +* DOUBLE PRECISION VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQP2 computes a QR factorization with column pivoting of +*> the block A(OFFSET+1:M,1:N). +*> The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] OFFSET +*> \verbatim +*> OFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but no factorized. OFFSET >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the M-by-N matrix A. +*> On exit, the upper triangle of block A(OFFSET+1:M,1:N) is +*> the triangular factor obtained; the elements in block +*> A(OFFSET+1:M,1:N) below the diagonal, together with the +*> array TAU, represent the orthogonal matrix Q as a product of +*> elementary reflectors. Block A(1:OFFSET,1:N) has been +*> accordingly pivoted, but no factorized. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] JPVT +*> \verbatim +*> JPVT is INTEGER array, dimension (N) +*> On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted +*> to the front of A*P (a leading column); if JPVT(i) = 0, +*> the i-th column of A is a free column. +*> On exit, if JPVT(i) = k, then the i-th column of A*P +*> was the k-th column of A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2 +* +*> \par Contributors: +* ================== +*> +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain +*> X. Sun, Computer Science Dept., Duke University, USA +*> \n +*> Partial column norm updating strategy modified on April 2011 +*> Z. Drmac and Z. Bujanovic, Dept. of Mathematics, +*> University of Zagreb, Croatia. +* +*> \par References: +* ================ +*> +*> LAPACK Working Note 176 +* +*> [PDF] +* +* ===================================================================== + SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, + $ WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER LDA, M, N, OFFSET +* .. +* .. Array Arguments .. + INTEGER JPVT( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + COMPLEX*16 CONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, MN, OFFPI, PVT + DOUBLE PRECISION TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL ZLARF1F, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCONJG, MAX, MIN, SQRT +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL IDAMAX, DLAMCH, DZNRM2 +* .. +* .. Executable Statements .. +* + MN = MIN( M-OFFSET, N ) + TOL3Z = SQRT(DLAMCH('Epsilon')) +* +* Compute factorization. +* + DO 20 I = 1, MN +* + OFFPI = OFFSET + I +* +* Determine ith pivot column and swap if necessary. +* + PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 ) +* + IF( PVT.NE.I ) THEN + CALL ZSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 ) + ITEMP = JPVT( PVT ) + JPVT( PVT ) = JPVT( I ) + JPVT( I ) = ITEMP + VN1( PVT ) = VN1( I ) + VN2( PVT ) = VN2( I ) + END IF +* +* Generate elementary reflector H(i). +* + IF( OFFPI.LT.M ) THEN + CALL ZLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), + $ 1, + $ TAU( I ) ) + ELSE + CALL ZLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) ) + END IF +* + IF( I.LT.N ) THEN +* +* Apply H(i)**H to A(offset+i:m,i+1:n) from the left. +* + CALL ZLARF1F( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1, + $ CONJG( TAU( I ) ), A( OFFPI, I+1 ), LDA, + $ WORK( 1 ) ) + END IF +* +* Update partial column norms. +* + DO 10 J = I + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following 4 lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN + IF( OFFPI.LT.M ) THEN + VN1( J ) = DZNRM2( M-OFFPI, A( OFFPI+1, J ), 1 ) + VN2( J ) = VN1( J ) + ELSE + VN1( J ) = ZERO + VN2( J ) = ZERO + END IF + ELSE + VN1( J ) = VN1( J )*SQRT( TEMP ) + END IF + END IF + 10 CONTINUE +* + 20 CONTINUE +* + RETURN +* +* End of ZLAQP2 +* + END diff --git a/lapack-netlib/zlaqp2rk.f b/lapack-netlib/zlaqp2rk.f new file mode 100644 index 0000000000..0e0133ecfc --- /dev/null +++ b/lapack-netlib/zlaqp2rk.f @@ -0,0 +1,712 @@ +*> \brief \b ZLAQP2RK computes truncated QR factorization with column pivoting of a complex matrix block using Level 2 BLAS and overwrites a complex m-by-nrhs matrix B with Q**H * B. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZLAQP2RK + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, +* $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, +* $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, +* $ INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS +* DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, +* $ RELTOL +* .. +* .. Array Arguments .. +* INTEGER JPIV( * ) +* DOUBLE PRECISION VN1( * ), VN2( * ) +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* $ +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQP2RK computes a truncated (rank K) or full rank Householder QR +*> factorization with column pivoting of the complex matrix +*> block A(IOFFSET+1:M,1:N) as +*> +*> A * P(K) = Q(K) * R(K). +*> +*> The routine uses Level 2 BLAS. The block A(1:IOFFSET,1:N) +*> is accordingly pivoted, but not factorized. +*> +*> The routine also overwrites the right-hand-sides matrix block B +*> stored in A(IOFFSET+1:M,N+1:N+NRHS) with Q(K)**H * B. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand sides, i.e., the number of +*> columns of the matrix B. NRHS >= 0. +*> \endverbatim +*> +*> \param[in] IOFFSET +*> \verbatim +*> IOFFSET is INTEGER +*> The number of rows of the matrix A that must be pivoted +*> but not factorized. IOFFSET >= 0. +*> +*> IOFFSET also represents the number of columns of the whole +*> original matrix A_orig that have been factorized +*> in the previous steps. +*> \endverbatim +*> +*> \param[in] KMAX +*> \verbatim +*> KMAX is INTEGER +*> +*> The first factorization stopping criterion. KMAX >= 0. +*> +*> The maximum number of columns of the matrix A to factorize, +*> i.e. the maximum factorization rank. +*> +*> a) If KMAX >= min(M-IOFFSET,N), then this stopping +*> criterion is not used, factorize columns +*> depending on ABSTOL and RELTOL. +*> +*> b) If KMAX = 0, then this stopping criterion is +*> satisfied on input and the routine exits immediately. +*> This means that the factorization is not performed, +*> the matrices A and B and the arrays TAU, IPIV +*> are not modified. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second factorization stopping criterion. +*> +*> The absolute tolerance (stopping threshold) for +*> maximum column 2-norm of the residual matrix. +*> The algorithm converges (stops the factorization) when +*> the maximum column 2-norm of the residual matrix +*> is less than or equal to ABSTOL. +*> +*> a) If ABSTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and RELTOL. +*> This includes the case ABSTOL = -Inf. +*> +*> b) If 0.0 <= ABSTOL then the input value +*> of ABSTOL is used. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third factorization stopping criterion. +*> +*> The tolerance (stopping threshold) for the ratio of the +*> maximum column 2-norm of the residual matrix to the maximum +*> column 2-norm of the original matrix A_orig. The algorithm +*> converges (stops the factorization), when this ratio is +*> less than or equal to RELTOL. +*> +*> a) If RELTOL < 0.0, then this stopping criterion is not +*> used, the routine factorizes columns depending +*> on KMAX and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> d) If 0.0 <= RELTOL then the input value of RELTOL +*> is used. +*> \endverbatim +*> +*> \param[in] KP1 +*> \verbatim +*> KP1 is INTEGER +*> The index of the column with the maximum 2-norm in +*> the whole original matrix A_orig determined in the +*> main routine ZGEQP3RK. 1 <= KP1 <= N_orig_mat. +*> \endverbatim +*> +*> \param[in] MAXC2NRM +*> \verbatim +*> MAXC2NRM is DOUBLE PRECISION +*> The maximum column 2-norm of the whole original +*> matrix A_orig computed in the main routine ZGEQP3RK. +*> MAXC2NRM >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N+NRHS) +*> On entry: +*> the M-by-N matrix A and M-by-NRHS matrix B, as in +*> +*> N NRHS +*> array_A = M [ mat_A, mat_B ] +*> +*> On exit: +*> 1. The elements in block A(IOFFSET+1:M,1:K) below +*> the diagonal together with the array TAU represent +*> the unitary matrix Q(K) as a product of elementary +*> reflectors. +*> 2. The upper triangular block of the matrix A stored +*> in A(IOFFSET+1:M,1:K) is the triangular factor obtained. +*> 3. The block of the matrix A stored in A(1:IOFFSET,1:N) +*> has been accordingly pivoted, but not factorized. +*> 4. The rest of the array A, block A(IOFFSET+1:M,K+1:N+NRHS). +*> The left part A(IOFFSET+1:M,K+1:N) of this block +*> contains the residual of the matrix A, and, +*> if NRHS > 0, the right part of the block +*> A(IOFFSET+1:M,N+1:N+NRHS) contains the block of +*> the right-hand-side matrix B. Both these blocks have been +*> updated by multiplication from the left by Q(K)**H. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> Factorization rank of the matrix A, i.e. the rank of +*> the factor R, which is the same as the number of non-zero +*> rows of the factor R. 0 <= K <= min(M-IOFFSET,KMAX,N). +*> +*> K also represents the number of non-zero Householder +*> vectors. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix, +*> when the factorization stopped at rank K. MAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM of the maximum column +*> 2-norm of the residual matrix (when the factorization +*> stopped at rank K) to the maximum column 2-norm of the +*> whole original matrix A. RELMAXC2NRMK >= 0. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column pivot indices, for 1 <= j <= N, column j +*> of the matrix A was interchanged with column JPIV(j). +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M-IOFFSET,N)) +*> The scalar factors of the elementary reflectors. +*> \endverbatim +*> +*> \param[in,out] VN1 +*> \verbatim +*> VN1 is DOUBLE PRECISION array, dimension (N) +*> The vector with the partial column norms. +*> \endverbatim +*> +*> \param[in,out] VN2 +*> \verbatim +*> VN2 is DOUBLE PRECISION array, dimension (N) +*> The vector with the exact column norms. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N-1) +*> Used in ZLARF1F subroutine to apply an elementary +*> reflector from the left. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> 1) INFO = 0: successful exit. +*> 2) If INFO = j_1, where 1 <= j_1 <= N, then NaN was +*> detected and the routine stops the computation. +*> The j_1-th column of the matrix A or the j_1-th +*> element of array TAU contains the first occurrence +*> of NaN in the factorization step K+1 ( when K columns +*> have been factorized ). +*> +*> On exit: +*> K is set to the number of +*> factorized columns without +*> exception. +*> MAXC2NRMK is set to NaN. +*> RELMAXC2NRMK is set to NaN. +*> TAU(K+1:min(M,N)) is not set and contains undefined +*> elements. If j_1=K+1, TAU(K+1) +*> may contain NaN. +*> 3) If INFO = j_2, where N+1 <= j_2 <= 2*N, then no NaN +*> was detected, but +Inf (or -Inf) was detected and +*> the routine continues the computation until completion. +*> The (j_2-N)-th column of the matrix A contains the first +*> occurrence of +Inf (or -Inf) in the factorization +*> step K+1 ( when K columns have been factorized ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqp2rk +* +*> \par References: +* ================ +*> [1] A Level 3 BLAS QR factorization algorithm with column pivoting developed in 1996. +*> G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain. +*> X. Sun, Computer Science Dept., Duke University, USA. +*> C. H. Bischof, Math. and Comp. Sci. Div., Argonne National Lab, USA. +*> A BLAS-3 version of the QR factorization with column pivoting. +*> LAPACK Working Note 114 +*> https://www.netlib.org/lapack/lawnspdf/lawn114.pdf +*> and in +*> SIAM J. Sci. Comput., 19(5):1486-1494, Sept. 1998. +*> https://doi.org/10.1137/S1064827595296732 +*> +*> [2] A partial column norm updating strategy developed in 2006. +*> Z. Drmac and Z. Bujanovic, Dept. of Math., University of Zagreb, Croatia. +*> On the failure of rank revealing QR factorization software – a case study. +*> LAPACK Working Note 176. +*> http://www.netlib.org/lapack/lawnspdf/lawn176.pdf +*> and in +*> ACM Trans. Math. Softw. 35, 2, Article 12 (July 2008), 28 pages. +*> https://doi.org/10.1145/1377612.1377616 +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> November 2023, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> +*> \endverbatim +* +* ===================================================================== + SUBROUTINE ZLAQP2RK( M, N, NRHS, IOFFSET, KMAX, ABSTOL, RELTOL, + $ KP1, MAXC2NRM, A, LDA, K, MAXC2NRMK, + $ RELMAXC2NRMK, JPIV, TAU, VN1, VN2, WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER INFO, IOFFSET, KP1, K, KMAX, LDA, M, N, NRHS + DOUBLE PRECISION ABSTOL, MAXC2NRM, MAXC2NRMK, RELMAXC2NRMK, + $ RELTOL +* .. +* .. Array Arguments .. + INTEGER JPIV( * ) + DOUBLE PRECISION VN1( * ), VN2( * ) + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, ITEMP, J, JMAXC2NRM, KK, KP, + $ KBOUND, MINMNFACT, MINMNUPDT + DOUBLE PRECISION HUGEVAL, TAUNAN, TEMP, TEMP2, TOL3Z +* .. +* .. External Subroutines .. + EXTERNAL ZLARF1F, ZLARFG, ZSWAP +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT +* .. +* .. External Functions .. + LOGICAL DISNAN + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DZNRM2 + EXTERNAL DISNAN, DLAMCH, IDAMAX, DZNRM2 +* .. +* .. Executable Statements .. +* +* Initialize INFO +* + INFO = 0 +* +* MINMNFACT in the smallest dimension of the submatrix +* A(IOFFSET+1:M,1:N) to be factorized. +* +* MINMNUPDT is the smallest dimension +* of the subarray A(IOFFSET+1:M,1:N+NRHS) to be udated, which +* contains the submatrices A(IOFFSET+1:M,1:N) and +* B(IOFFSET+1:M,1:NRHS) as column blocks. +* + MINMNFACT = MIN( M-IOFFSET, N ) + MINMNUPDT = MIN( M-IOFFSET, N+NRHS ) + KBOUND = MIN( KMAX, MINMNFACT ) + TOL3Z = SQRT( DLAMCH( 'Epsilon' ) ) + HUGEVAL = DLAMCH( 'Overflow' ) +* +* Compute the factorization, KK is the lomn loop index. +* + DO KK = 1, KBOUND +* + I = IOFFSET + KK +* + IF( I.EQ.1 ) THEN +* +* ============================================================ +* +* We are at the first column of the original whole matrix A, +* therefore we use the computed KP1 and MAXC2NRM from the +* main routine. +* + KP = KP1 +* +* ============================================================ +* + ELSE +* +* ============================================================ +* +* Determine the pivot column in KK-th step, i.e. the index +* of the column with the maximum 2-norm in the +* submatrix A(I:M,K:N). +* + KP = ( KK-1 ) + IDAMAX( N-KK+1, VN1( KK ), 1 ) +* +* Determine the maximum column 2-norm and the relative maximum +* column 2-norm of the submatrix A(I:M,KK:N) in step KK. +* RELMAXC2NRMK will be computed later, after somecondition +* checks on MAXC2NRMK. +* + MAXC2NRMK = VN1( KP ) +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains NaN, and set +* INFO parameter to the column number, where the first NaN +* is found and return from the routine. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( DISNAN( MAXC2NRMK ) ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + INFO = K + KP +* +* Set RELMAXC2NRMK to NaN. +* + RELMAXC2NRMK = MAXC2NRMK +* +* Array TAU(K+1:MINMNFACT) is not set and contains +* undefined elements. +* + RETURN + END IF +* +* ============================================================ +* +* Quick return, if the submatrix A(I:M,KK:N) is +* a zero matrix. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( MAXC2NRMK.EQ.ZERO ) THEN +* +* Set K, the number of factorized columns. +* that are not zero. +* + K = KK - 1 + RELMAXC2NRMK = ZERO +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* Check if the submatrix A(I:M,KK:N) contains Inf, +* set INFO parameter to the column number, where +* the first Inf is found plus N, and continue +* the computation. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. +* + IF( INFO.EQ.0 .AND. MAXC2NRMK.GT.HUGEVAL ) THEN + INFO = N + KK - 1 + KP + END IF +* +* ============================================================ +* +* Test for the second and third stopping criteria. +* NOTE: There is no need to test for ABSTOL >= ZERO, since +* MAXC2NRMK is non-negative. Similarly, there is no need +* to test for RELTOL >= ZERO, since RELMAXC2NRMK is +* non-negative. +* We need to check the condition only if the +* column index (same as row index) of the original whole +* matrix is larger than 1, since the condition for whole +* original matrix is checked in the main routine. + + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + IF( MAXC2NRMK.LE.ABSTOL .OR. RELMAXC2NRMK.LE.RELTOL ) THEN +* +* Set K, the number of factorized columns. +* + K = KK - 1 +* +* Set TAUs corresponding to the columns that were not +* factorized to ZERO, i.e. set TAU(KK:MINMNFACT) to CZERO. +* + DO J = KK, MINMNFACT + TAU( J ) = CZERO + END DO +* +* Return from the routine. +* + RETURN +* + END IF +* +* ============================================================ +* +* End ELSE of IF(I.EQ.1) +* + END IF +* +* =============================================================== +* +* If the pivot column is not the first column of the +* subblock A(1:M,KK:N): +* 1) swap the KK-th column and the KP-th pivot column +* in A(1:M,1:N); +* 2) copy the KK-th element into the KP-th element of the partial +* and exact 2-norm vectors VN1 and VN2. ( Swap is not needed +* for VN1 and VN2 since we use the element with the index +* larger than KK in the next loop step.) +* 3) Save the pivot interchange with the indices relative to the +* the original matrix A, not the block A(1:M,1:N). +* + IF( KP.NE.KK ) THEN + CALL ZSWAP( M, A( 1, KP ), 1, A( 1, KK ), 1 ) + VN1( KP ) = VN1( KK ) + VN2( KP ) = VN2( KK ) + ITEMP = JPIV( KP ) + JPIV( KP ) = JPIV( KK ) + JPIV( KK ) = ITEMP + END IF +* +* Generate elementary reflector H(KK) using the column A(I:M,KK), +* if the column has more than one element, otherwise +* the elementary reflector would be an identity matrix, +* and TAU(KK) = CZERO. +* + IF( I.LT.M ) THEN + CALL ZLARFG( M-I+1, A( I, KK ), A( I+1, KK ), 1, + $ TAU( KK ) ) + ELSE + TAU( KK ) = CZERO + END IF +* +* Check if TAU(KK) contains NaN, set INFO parameter +* to the column number where NaN is found and return from +* the routine. +* NOTE: There is no need to check TAU(KK) for Inf, +* since ZLARFG cannot produce TAU(KK) or Householder vector +* below the diagonal containing Inf. Only BETA on the diagonal, +* returned by ZLARFG can contain Inf, which requires +* TAU(KK) to contain NaN. Therefore, this case of generating Inf +* by ZLARFG is covered by checking TAU(KK) for NaN. +* + IF( DISNAN( DBLE( TAU(KK) ) ) ) THEN + TAUNAN = DBLE( TAU(KK) ) + ELSE IF( DISNAN( DIMAG( TAU(KK) ) ) ) THEN + TAUNAN = DIMAG( TAU(KK) ) + ELSE + TAUNAN = ZERO + END IF +* + IF( DISNAN( TAUNAN ) ) THEN + K = KK - 1 + INFO = KK +* +* Set MAXC2NRMK and RELMAXC2NRMK to NaN. +* + MAXC2NRMK = TAUNAN + RELMAXC2NRMK = TAUNAN +* +* Array TAU(KK:MINMNFACT) is not set and contains +* undefined elements, except the first element TAU(KK) = NaN. +* + RETURN + END IF +* +* Apply H(KK)**H to A(I:M,KK+1:N+NRHS) from the left. +* ( If M >= N, then at KK = N there is no residual matrix, +* i.e. no columns of A to update, only columns of B. +* If M < N, then at KK = M-IOFFSET, I = M and we have a +* one-row residual matrix in A and the elementary +* reflector is a unit matrix, TAU(KK) = CZERO, i.e. no update +* is needed for the residual matrix in A and the +* right-hand-side-matrix in B. +* Therefore, we update only if +* KK < MINMNUPDT = min(M-IOFFSET, N+NRHS) +* condition is satisfied, not only KK < N+NRHS ) +* + IF( KK.LT.MINMNUPDT ) THEN + CALL ZLARF1F( 'Left', M-I+1, N+NRHS-KK, A( I, KK ), 1, + $ CONJG( TAU( KK ) ), A( I, KK+1 ), LDA, + $ WORK( 1 ) ) + END IF +* + IF( KK.LT.MINMNFACT ) THEN +* +* Update the partial column 2-norms for the residual matrix, +* only if the residual matrix A(I+1:M,KK+1:N) exists, i.e. +* when KK < min(M-IOFFSET, N). +* + DO J = KK + 1, N + IF( VN1( J ).NE.ZERO ) THEN +* +* NOTE: The following lines follow from the analysis in +* Lapack Working Note 176. +* + TEMP = ONE - ( ABS( A( I, J ) ) / VN1( J ) )**2 + TEMP = MAX( TEMP, ZERO ) + TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2 + IF( TEMP2 .LE. TOL3Z ) THEN +* +* Compute the column 2-norm for the partial +* column A(I+1:M,J) by explicitly computing it, +* and store it in both partial 2-norm vector VN1 +* and exact column 2-norm vector VN2. +* + VN1( J ) = DZNRM2( M-I, A( I+1, J ), 1 ) + VN2( J ) = VN1( J ) +* + ELSE +* +* Update the column 2-norm for the partial +* column A(I+1:M,J) by removing one +* element A(I,J) and store it in partial +* 2-norm vector VN1. +* + VN1( J ) = VN1( J )*SQRT( TEMP ) +* + END IF + END IF + END DO +* + END IF +* +* End factorization loop +* + END DO +* +* If we reached this point, all colunms have been factorized, +* i.e. no condition was triggered to exit the routine. +* Set the number of factorized columns. +* + K = KBOUND +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, we need to set MAXC2NRMK and RELMAXC2NRMK before +* we return. +* + IF( K.LT.MINMNFACT ) THEN +* + JMAXC2NRM = K + IDAMAX( N-K, VN1( K+1 ), 1 ) + MAXC2NRMK = VN1( JMAXC2NRM ) +* + IF( K.EQ.0 ) THEN + RELMAXC2NRMK = ONE + ELSE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM + END IF +* + ELSE + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + END IF +* +* We reached the end of the loop, i.e. all KMAX columns were +* factorized, set TAUs corresponding to the columns that were +* not factorized to ZERO, i.e. TAU(K+1:MINMNFACT) set to CZERO. +* + DO J = K + 1, MINMNFACT + TAU( J ) = CZERO + END DO +* + RETURN +* +* End of ZLAQP2RK +* + END diff --git a/lapack-netlib/zlaqr2.f b/lapack-netlib/zlaqr2.f new file mode 100644 index 0000000000..5cab69b91c --- /dev/null +++ b/lapack-netlib/zlaqr2.f @@ -0,0 +1,569 @@ +*> \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZLAQR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, +* NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), +* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLAQR2 is identical to ZLAQR3 except that it avoids +*> recursion by calling ZLAHQR instead of ZLAQR4. +*> +*> Aggressive early deflation: +*> +*> ZLAQR2 accepts as input an upper Hessenberg matrix +*> H and performs an unitary similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an unitary similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the unitary matrix Z is updated so +*> so that the unitary Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the unitary matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 <= NW <= (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by a unitary +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> Leading dimension of H just as declared in the calling +*> subroutine. N <= LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 <= LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SH +*> \verbatim +*> SH is COMPLEX*16 array, dimension (KBOT) +*> On output, approximate eigenvalues that may +*> be used for shifts are stored in SH(KBOT-ND-NS+1) +*> through SR(KBOT-ND). Converged eigenvalues are +*> stored in SH(KBOT-ND+1) through SH(KBOT). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> The number of columns of T. NH >= NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of T just as declared in the +*> calling subroutine. NW <= LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> The number of rows of work array WV available for +*> workspace. NV >= NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is COMPLEX*16 array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> The leading dimension of W just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; ZLAQR2 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqr2 +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWKOPT +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEHRD, ZGEMM, ZLACPY, + $ ZLAHQR, + $ ZLARF1F, ZLARFG, ZLASET, ZTREXC, ZUNMHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + CALL ZUNMHR( 'R', 'N', JW, JW, 1, JW-1, T, LDT, WORK, V, + $ LDV, + $ WORK, -1, INFO ) + LWK2 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = JW + MAX( LWK1, LWK2 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + 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 +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), 1, + $ JW, V, LDV, INFQR ) +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + CALL ZLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) +* + CALL ZLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + 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 ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR2 ==== +* + END diff --git a/lapack-netlib/zlaqr3.f b/lapack-netlib/zlaqr3.f new file mode 100644 index 0000000000..9a696fe115 --- /dev/null +++ b/lapack-netlib/zlaqr3.f @@ -0,0 +1,583 @@ +*> \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and deflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZLAQR3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, +* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, +* NV, WV, LDWV, WORK, LWORK ) +* +* .. Scalar Arguments .. +* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, +* $ LDZ, LWORK, N, ND, NH, NS, NV, NW +* LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. +* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), +* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> Aggressive early deflation: +*> +*> ZLAQR3 accepts as input an upper Hessenberg matrix +*> H and performs an unitary similarity transformation +*> designed to detect and deflate fully converged eigenvalues from +*> a trailing principal submatrix. On output H has been over- +*> written by a new Hessenberg matrix that is a perturbation of +*> an unitary similarity transformation of H. It is to be +*> hoped that the final version of H has many zero subdiagonal +*> entries. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] WANTT +*> \verbatim +*> WANTT is LOGICAL +*> If .TRUE., then the Hessenberg matrix H is fully updated +*> so that the triangular Schur factor may be +*> computed (in cooperation with the calling subroutine). +*> If .FALSE., then only enough of H is updated to preserve +*> the eigenvalues. +*> \endverbatim +*> +*> \param[in] WANTZ +*> \verbatim +*> WANTZ is LOGICAL +*> If .TRUE., then the unitary matrix Z is updated so +*> so that the unitary Schur factor may be computed +*> (in cooperation with the calling subroutine). +*> If .FALSE., then Z is not referenced. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix H and (if WANTZ is .TRUE.) the +*> order of the unitary matrix Z. +*> \endverbatim +*> +*> \param[in] KTOP +*> \verbatim +*> KTOP is INTEGER +*> It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. +*> KBOT and KTOP together determine an isolated block +*> along the diagonal of the Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] KBOT +*> \verbatim +*> KBOT is INTEGER +*> It is assumed without a check that either +*> KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together +*> determine an isolated block along the diagonal of the +*> Hessenberg matrix. +*> \endverbatim +*> +*> \param[in] NW +*> \verbatim +*> NW is INTEGER +*> Deflation window size. 1 <= NW <= (KBOT-KTOP+1). +*> \endverbatim +*> +*> \param[in,out] H +*> \verbatim +*> H is COMPLEX*16 array, dimension (LDH,N) +*> On input the initial N-by-N section of H stores the +*> Hessenberg matrix undergoing aggressive early deflation. +*> On output H has been transformed by a unitary +*> similarity transformation, perturbed, and the returned +*> to Hessenberg form that (it is to be hoped) has some +*> zero subdiagonal entries. +*> \endverbatim +*> +*> \param[in] LDH +*> \verbatim +*> LDH is INTEGER +*> Leading dimension of H just as declared in the calling +*> subroutine. N <= LDH +*> \endverbatim +*> +*> \param[in] ILOZ +*> \verbatim +*> ILOZ is INTEGER +*> \endverbatim +*> +*> \param[in] IHIZ +*> \verbatim +*> IHIZ is INTEGER +*> Specify the rows of Z to which transformations must be +*> applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. +*> \endverbatim +*> +*> \param[in,out] Z +*> \verbatim +*> Z is 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,ILOZ:IHIZ) from the right. +*> If WANTZ is .FALSE., then Z is unreferenced. +*> \endverbatim +*> +*> \param[in] LDZ +*> \verbatim +*> LDZ is INTEGER +*> The leading dimension of Z just as declared in the +*> calling subroutine. 1 <= LDZ. +*> \endverbatim +*> +*> \param[out] NS +*> \verbatim +*> NS is INTEGER +*> The number of unconverged (ie approximate) eigenvalues +*> returned in SR and SI that may be used as shifts by the +*> calling subroutine. +*> \endverbatim +*> +*> \param[out] ND +*> \verbatim +*> ND is INTEGER +*> The number of converged eigenvalues uncovered by this +*> subroutine. +*> \endverbatim +*> +*> \param[out] SH +*> \verbatim +*> SH is COMPLEX*16 array, dimension (KBOT) +*> On output, approximate eigenvalues that may +*> be used for shifts are stored in SH(KBOT-ND-NS+1) +*> through SR(KBOT-ND). Converged eigenvalues are +*> stored in SH(KBOT-ND+1) through SH(KBOT). +*> \endverbatim +*> +*> \param[out] V +*> \verbatim +*> V is COMPLEX*16 array, dimension (LDV,NW) +*> An NW-by-NW work array. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of V just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[in] NH +*> \verbatim +*> NH is INTEGER +*> The number of columns of T. NH >= NW. +*> \endverbatim +*> +*> \param[out] T +*> \verbatim +*> T is COMPLEX*16 array, dimension (LDT,NW) +*> \endverbatim +*> +*> \param[in] LDT +*> \verbatim +*> LDT is INTEGER +*> The leading dimension of T just as declared in the +*> calling subroutine. NW <= LDT +*> \endverbatim +*> +*> \param[in] NV +*> \verbatim +*> NV is INTEGER +*> The number of rows of work array WV available for +*> workspace. NV >= NW. +*> \endverbatim +*> +*> \param[out] WV +*> \verbatim +*> WV is COMPLEX*16 array, dimension (LDWV,NW) +*> \endverbatim +*> +*> \param[in] LDWV +*> \verbatim +*> LDWV is INTEGER +*> The leading dimension of W just as declared in the +*> calling subroutine. NW <= LDV +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> On exit, WORK(1) is set to an estimate of the optimal value +*> of LWORK for the given values of N, NW, KTOP and KBOT. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the work array WORK. LWORK = 2*NW +*> suffices, but greater efficiency may result from larger +*> values of LWORK. +*> +*> If LWORK = -1, then a workspace query is assumed; ZLAQR3 +*> only estimates the optimal workspace size for the given +*> values of N, NW, KTOP and KBOT. The estimate is returned +*> in WORK(1). No error message related to LWORK is issued +*> by XERBLA. Neither H nor Z are accessed. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup laqr3 +* +*> \par Contributors: +* ================== +*> +*> Karen Braman and Ralph Byers, Department of Mathematics, +*> University of Kansas, USA +*> +* ===================================================================== + SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, + $ ILOZ, + $ IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, + $ NV, WV, LDWV, WORK, LWORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, + $ LDZ, LWORK, N, ND, NH, NS, NV, NW + LOGICAL WANTT, WANTZ +* .. +* .. Array Arguments .. + COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), + $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) +* .. +* +* ================================================================ +* +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0d0, 0.0d0 ), + $ ONE = ( 1.0d0, 0.0d0 ) ) + DOUBLE PRECISION RZERO, RONE + PARAMETER ( RZERO = 0.0d0, RONE = 1.0d0 ) +* .. +* .. Local Scalars .. + COMPLEX*16 CDUM, S, TAU + DOUBLE PRECISION FOO, SAFMAX, SAFMIN, SMLNUM, ULP + INTEGER I, IFST, ILST, INFO, INFQR, J, JW, KCOL, KLN, + $ KNT, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3, + $ LWKOPT, NMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + INTEGER ILAENV + EXTERNAL DLAMCH, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGEHRD, ZGEMM, ZLACPY, ZLAHQR, + $ ZLAQR4, + $ ZLARF1F, ZLARFG, ZLASET, ZTREXC, ZUNMHR +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, INT, MAX, MIN +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( CDUM ) = ABS( DBLE( CDUM ) ) + ABS( DIMAG( CDUM ) ) +* .. +* .. Executable Statements .. +* +* ==== Estimate optimal workspace. ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + IF( JW.LE.2 ) THEN + LWKOPT = 1 + ELSE +* +* ==== Workspace query call to ZGEHRD ==== +* + CALL ZGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO ) + LWK1 = INT( WORK( 1 ) ) +* +* ==== Workspace query call to ZUNMHR ==== +* + 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 ==== +* + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH, 1, JW, + $ V, + $ LDV, WORK, -1, INFQR ) + LWK3 = INT( WORK( 1 ) ) +* +* ==== Optimal workspace ==== +* + LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 ) + END IF +* +* ==== Quick return in case of workspace query. ==== +* + IF( LWORK.EQ.-1 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) + RETURN + END IF +* +* ==== Nothing to do ... +* ... for an empty active block ... ==== + NS = 0 + ND = 0 + WORK( 1 ) = ONE + IF( KTOP.GT.KBOT ) + $ RETURN +* ... nor for an empty deflation window. ==== + IF( NW.LT.1 ) + $ RETURN +* +* ==== Machine constants ==== +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + SAFMAX = RONE / SAFMIN + ULP = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN*( DBLE( N ) / ULP ) +* +* ==== Setup deflation window ==== +* + JW = MIN( NW, KBOT-KTOP+1 ) + KWTOP = KBOT - JW + 1 + IF( KWTOP.EQ.KTOP ) THEN + S = ZERO + ELSE + S = H( KWTOP, KWTOP-1 ) + END IF +* + IF( KBOT.EQ.KWTOP ) THEN +* +* ==== 1-by-1 deflation window: not much to do ==== +* + SH( KWTOP ) = H( KWTOP, KWTOP ) + NS = 1 + 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 +* +* ==== Convert to spike-triangular form. (In case of a +* . rare QR failure, this routine continues to do +* . aggressive early deflation using that part of +* . the deflation window that converged using INFQR +* . here and there to keep track.) ==== +* + CALL ZLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT ) + CALL ZCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), + $ LDT+1 ) +* + CALL ZLASET( 'A', JW, JW, ZERO, ONE, V, LDV ) + NMIN = ILAENV( 12, 'ZLAQR3', 'SV', JW, 1, JW, LWORK ) + IF( JW.GT.NMIN ) THEN + CALL ZLAQR4( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), + $ 1, + $ JW, V, LDV, WORK, LWORK, INFQR ) + ELSE + CALL ZLAHQR( .true., .true., JW, 1, JW, T, LDT, SH( KWTOP ), + $ 1, + $ JW, V, LDV, INFQR ) + END IF +* +* ==== Deflation detection loop ==== +* + NS = JW + ILST = INFQR + 1 + DO 10 KNT = INFQR + 1, JW +* +* ==== Small spike tip deflation test ==== +* + FOO = CABS1( T( NS, NS ) ) + IF( FOO.EQ.RZERO ) + $ FOO = CABS1( S ) + IF( CABS1( S )*CABS1( V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) + $ THEN +* +* ==== One more converged eigenvalue ==== +* + NS = NS - 1 + ELSE +* +* ==== One undeflatable eigenvalue. Move it up out of the +* . way. (ZTREXC can not fail in this case.) ==== +* + IFST = NS + CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, INFO ) + ILST = ILST + 1 + END IF + 10 CONTINUE +* +* ==== Return to Hessenberg form ==== +* + IF( NS.EQ.0 ) + $ S = ZERO +* + IF( NS.LT.JW ) THEN +* +* ==== sorting the diagonal of T improves accuracy for +* . graded matrices. ==== +* + DO 30 I = INFQR + 1, NS + IFST = I + DO 20 J = I + 1, NS + IF( CABS1( T( J, J ) ).GT.CABS1( T( IFST, IFST ) ) ) + $ IFST = J + 20 CONTINUE + ILST = I + IF( IFST.NE.ILST ) + $ CALL ZTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, + $ INFO ) + 30 CONTINUE + END IF +* +* ==== Restore shift/eigenvalue array from T ==== +* + DO 40 I = INFQR + 1, JW + SH( KWTOP+I-1 ) = T( I, I ) + 40 CONTINUE +* +* + IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN + IF( NS.GT.1 .AND. S.NE.ZERO ) THEN +* +* ==== Reflect spike back into lower triangle ==== +* + CALL ZCOPY( NS, V, LDV, WORK, 1 ) + DO 50 I = 1, NS + WORK( I ) = DCONJG( WORK( I ) ) + 50 CONTINUE + CALL ZLARFG( NS, WORK( 1 ), WORK( 2 ), 1, TAU ) +* + CALL ZLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), + $ LDT ) +* + CALL ZLARF1F( 'L', NS, JW, WORK, 1, CONJG( TAU ), T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF1F( 'R', NS, NS, WORK, 1, TAU, T, LDT, + $ WORK( JW+1 ) ) + CALL ZLARF1F( 'R', JW, NS, WORK, 1, TAU, V, LDV, + $ WORK( JW+1 ) ) +* + CALL ZGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ), + $ LWORK-JW, INFO ) + END IF +* +* ==== Copy updated reduced window into place ==== +* + IF( KWTOP.GT.1 ) + $ H( KWTOP, KWTOP-1 ) = S*DCONJG( V( 1, 1 ) ) + CALL ZLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH ) + CALL ZCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ), + $ LDH+1 ) +* +* ==== Accumulate orthogonal matrix in order update +* . H and Z, if requested. ==== +* + 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 ==== +* + IF( WANTT ) THEN + LTOP = 1 + ELSE + LTOP = KTOP + END IF + DO 60 KROW = LTOP, KWTOP - 1, NV + KLN = MIN( NV, KWTOP-KROW ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ), + $ LDH, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), + $ LDH ) + 60 CONTINUE +* +* ==== Update horizontal slab in H ==== +* + IF( WANTT ) THEN + DO 70 KCOL = KBOT + 1, N, NH + KLN = MIN( NH, N-KCOL+1 ) + CALL ZGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV, + $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT ) + CALL ZLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ), + $ LDH ) + 70 CONTINUE + END IF +* +* ==== Update vertical slab in Z ==== +* + IF( WANTZ ) THEN + DO 80 KROW = ILOZ, IHIZ, NV + KLN = MIN( NV, IHIZ-KROW+1 ) + CALL ZGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, + $ KWTOP ), + $ LDZ, V, LDV, ZERO, WV, LDWV ) + CALL ZLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ), + $ LDZ ) + 80 CONTINUE + END IF + END IF +* +* ==== Return the number of deflations ... ==== +* + ND = JW - NS +* +* ==== ... and the number of shifts. (Subtracting +* . INFQR from the spike length takes care +* . of the case of a rare QR failure while +* . calculating eigenvalues of the deflation +* . window.) ==== +* + NS = NS - INFQR +* +* ==== Return optimal workspace. ==== +* + WORK( 1 ) = DCMPLX( LWKOPT, 0 ) +* +* ==== End of ZLAQR3 ==== +* + END diff --git a/lapack-netlib/zlarf1f.f b/lapack-netlib/zlarf1f.f new file mode 100644 index 0000000000..adaca3c9b4 --- /dev/null +++ b/lapack-netlib/zlarf1f.f @@ -0,0 +1,302 @@ +*> \brief \b ZLARF1F applies an elementary reflector to a general rectangular +* matrix assuming v(1) = 1. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZLARF1F + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX*16 TAU +* .. +* .. Array Arguments .. +* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARF1F applies a complex elementary reflector H to a real m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a complex scalar and v is a complex vector. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H, supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. V(1) is not referenced or modified. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV <> 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* To take advantage of the fact that v(1) = 1, we do the following +* v = [ 1 v_2 ]**T +* If SIDE='L' +* |-----| +* | C_1 | +* C =| C_2 | +* |-----| +* C_1\in\mathbb{C}^{1\times n}, C_2\in\mathbb{C}^{m-1\times n} +* So we compute: +* C = HC = (I - \tau vv**T)C +* = C - \tau vv**T C +* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T +* = C_1**T + C_2**T v ( ZGEMM then ZAXPYC-like ) +* C = C - \tau vv**T C +* = C - \tau vw**T +* Giving us C_1 = C_1 - \tau w**T ( ZAXPYC-like ) +* and +* C_2 = C_2 - \tau v_2w**T ( ZGERC ) +* If SIDE='R' +* +* C = [ C_1 C_2 ] +* C_1\in\mathbb{C}^{m\times 1}, C_2\in\mathbb{C}^{m\times n-1} +* So we compute: +* C = CH = C(I - \tau vv**T) +* = C - \tau Cvv**T +* +* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T +* = C_1 + C_2v_2 ( ZGEMM then ZAXPYC-like ) +* C = C - \tau Cvv**T +* = C - \tau wv**T +* Giving us C_1 = C_1 - \tau w ( ZAXPYC-like ) +* and +* C_2 = C_2 - \tau wv_2**T ( ZGERC ) +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf +* +* ===================================================================== + SUBROUTINE ZLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, LASTV, LASTC, J +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZGEMV, ZGERC, ZSCAL +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL LSAME, ILAZLR, ILAZLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + LASTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V. + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + IF( INCV.GT.0 ) THEN + I = 1 + (LASTV-1) * INCV + ELSE + I = 1 + END IF +! Look for the last non-zero row in V. +! Since we are assuming that V(1) = 1, and it is not stored, so we +! shouldn't access it. + DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO ) + LASTV = LASTV - 1 + I = I - INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILAZLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILAZLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + ! Check if m = 1. This means v = 1, So we just need to compute + ! C := HC = (1-\tau)C. + IF( LASTV.EQ.1 ) THEN + CALL ZSCAL(LASTC, ONE - TAU, C, LDC) + ELSE +* +* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) +* + ! (I - tvv**H)C = C - tvv**H C + ! First compute w**H = v**H c -> w = C**H v + ! C = [ C_1 C_2 ]**T, v = [1 v_2]**T + ! w = C_1**H + C_2**Hv_2 + ! w = C_2**Hv_2 + CALL ZGEMV( 'Conjugate transpose', LASTV - 1, + $ LASTC, ONE, C( 1+1, 1 ), LDC, V( 1 + INCV ), + $ INCV, ZERO, WORK, 1 ) +* +* w(1:lastc,1) += v(1,1) * C(1,1:lastc)**H +* + DO I = 1, LASTC + WORK( I ) = WORK( I ) + DCONJG( C( 1, I ) ) + END DO +* +* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**H +* + ! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**H + ! = C(...) - tau * Conj(w(1:lastc,1)) + ! This is essentially a zaxpyc + DO I = 1, LASTC + C( 1, I ) = C( 1, I ) - TAU * DCONJG( WORK( I ) ) + END DO +* +* C(2:lastv,1:lastc) += - tau * v(2:lastv,1) * w(1:lastc,1)**H +* + CALL ZGERC( LASTV - 1, LASTC, -TAU, V( 1 + INCV ), + $ INCV, WORK, 1, C( 1+1, 1 ), LDC ) + END IF + ELSE +* +* Form C * H +* + ! Check if n = 1. This means v = 1, so we just need to compute + ! C := CH = C(1-\tau). + IF( LASTV.EQ.1 ) THEN + CALL ZSCAL(LASTC, ONE - TAU, C, 1) + ELSE +* +* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) +* + ! w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1) + CALL ZGEMV( 'No transpose', LASTC, LASTV-1, ONE, + $ C(1,1+1), LDC, V(1+INCV), INCV, ZERO, WORK, 1 ) + ! w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1) + CALL ZAXPY(LASTC, ONE, C, 1, WORK, 1) +* +* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T +* + ! C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)**T + ! = C(...) - tau * w(1:lastc,1) + CALL ZAXPY(LASTC, -TAU, WORK, 1, C, 1) + ! C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:lastv)**T + CALL ZGERC( LASTC, LASTV-1, -TAU, WORK, 1, V(1+INCV), + $ INCV, C(1,1+1), LDC ) + END IF + END IF + RETURN +* +* End of ZLARF1F +* + END diff --git a/lapack-netlib/zlarf1l.f b/lapack-netlib/zlarf1l.f new file mode 100644 index 0000000000..2a3bd1d373 --- /dev/null +++ b/lapack-netlib/zlarf1l.f @@ -0,0 +1,267 @@ +*> \brief \b ZLARF1L applies an elementary reflector to a general rectangular +* matrix assuming v(lastv) = 1, where lastv is the last non-zero +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZLARF1L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE +* INTEGER INCV, LDC, M, N +* COMPLEX*16 TAU +* .. +* .. Array Arguments .. +* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZLARF1L applies a complex elementary reflector H to a complex m by n matrix +*> C, from either the left or the right. H is represented in the form +*> +*> H = I - tau * v * v**H +*> +*> where tau is a real scalar and v is a real vector assuming v(lastv) = 1, +*> where lastv is the last non-zero element. +*> +*> If tau = 0, then H is taken to be the unit matrix. +*> +*> To apply H**H (the conjugate transpose of H), supply conjg(tau) instead +*> tau. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': form H * C +*> = 'R': form C * H +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. +*> \endverbatim +*> +*> \param[in] V +*> \verbatim +*> V is COMPLEX*16 array, dimension +*> (1 + (M-1)*abs(INCV)) if SIDE = 'L' +*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +*> The vector v in the representation of H. V is not used if +*> TAU = 0. +*> \endverbatim +*> +*> \param[in] INCV +*> \verbatim +*> INCV is INTEGER +*> The increment between elements of v. INCV > 0. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 +*> The value tau in the representation of H. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m by n matrix C. +*> On exit, C is overwritten by the matrix H * C if SIDE = 'L', +*> or C * H if SIDE = 'R'. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L' +*> or (M) if SIDE = 'R' +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup larf1f +* +* ===================================================================== + SUBROUTINE ZLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) + IMPLICIT NONE +* +* -- LAPACK auxiliary routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + COMPLEX*16 TAU +* .. +* .. Array Arguments .. + COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL APPLYLEFT + INTEGER I, J, LASTV, LASTC, FIRSTV +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZGEMV, ZGERC, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAZLR, ILAZLC + EXTERNAL LSAME, ILAZLR, ILAZLC +* .. +* .. Executable Statements .. +* + APPLYLEFT = LSAME( SIDE, 'L' ) + FIRSTV = 1 + LASTC = 0 + IF( TAU.NE.ZERO ) THEN +! Set up variables for scanning V. LASTV begins pointing to the end +! of V up to V(1). + IF( APPLYLEFT ) THEN + LASTV = M + ELSE + LASTV = N + END IF + I = 1 +! Look for the last non-zero row in V. + DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO ) + FIRSTV = FIRSTV + 1 + I = I + INCV + END DO + IF( APPLYLEFT ) THEN +! Scan for the last non-zero column in C(1:lastv,:). + LASTC = ILAZLC(LASTV, N, C, LDC) + ELSE +! Scan for the last non-zero row in C(:,1:lastv). + LASTC = ILAZLR(M, LASTV, C, LDC) + END IF + END IF + IF( LASTC.EQ.0 ) THEN + RETURN + END IF + IF( APPLYLEFT ) THEN +* +* Form H * C +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(lastv,1:lastc) := ( 1 - tau ) * C(lastv,1:lastc) +* + CALL ZSCAL( LASTC, ONE - TAU, C( LASTV, 1 ), LDC ) + ELSE +* +* w(1:lastc,1) := C(firstv:lastv-1,1:lastc)**T * v(firstv:lastv-1,1) +* + CALL ZGEMV( 'Conjugate transpose', LASTV - FIRSTV, LASTC, + $ ONE, C( FIRSTV, 1 ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += C(lastv,1:lastc)**H * v(lastv,1) +* + DO J = 1, LASTC + WORK( J ) = WORK( J ) + CONJG( C( LASTV, J ) ) + END DO +* +* C(lastv,1:lastc) += - tau * v(lastv,1) * w(1:lastc,1)**H +* + DO J = 1, LASTC + C( LASTV, J ) = C( LASTV, J ) + $ - TAU * CONJG( WORK( J ) ) + END DO +* +* C(firstv:lastv-1,1:lastc) += - tau * v(firstv:lastv-1,1) * w(1:lastc,1)**H +* + CALL ZGERC( LASTV - FIRSTV, LASTC, -TAU, V( I ), INCV, + $ WORK, 1, C( FIRSTV, 1 ), LDC) + END IF + ELSE +* +* Form C * H +* + IF( LASTV.EQ.FIRSTV ) THEN +* +* C(1:lastc,lastv) := ( 1 - tau ) * C(1:lastc,lastv) +* + CALL ZSCAL( LASTC, ONE - TAU, C( 1, LASTV ), 1 ) + ELSE +* +* w(1:lastc,1) := C(1:lastc,firstv:lastv-1) * v(firstv:lastv-1,1) +* + CALL ZGEMV( 'No transpose', LASTC, LASTV - FIRSTV, ONE, + $ C( 1, FIRSTV ), LDC, V( I ), INCV, ZERO, + $ WORK, 1 ) +* +* w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) +* + CALL ZAXPY( LASTC, ONE, C( 1, LASTV ), 1, WORK, 1 ) +* +* C(1:lastc,lastv) += - tau * v(lastv,1) * w(1:lastc,1) +* + CALL ZAXPY( LASTC, -TAU, WORK, 1, C( 1, LASTV ), 1 ) +* +* C(1:lastc,firstv:lastv-1) += - tau * w(1:lastc,1) * v(firstv:lastv-1)**H +* + CALL ZGERC( LASTC, LASTV - FIRSTV, -TAU, WORK, 1, V( I ), + $ INCV, C( 1, FIRSTV ), LDC ) + END IF + END IF + RETURN +* +* End of ZLARF1L +* + END diff --git a/lapack-netlib/zunbdb.f b/lapack-netlib/zunbdb.f new file mode 100644 index 0000000000..e0c8beadec --- /dev/null +++ b/lapack-netlib/zunbdb.f @@ -0,0 +1,704 @@ +*> \brief \b ZUNBDB +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNBDB + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, +* X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, +* TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIGNS, TRANS +* INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, +* $ Q +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI( * ), THETA( * ) +* COMPLEX*16 TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), +* $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), +* $ X21( LDX21, * ), X22( LDX22, * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M +*> partitioned unitary matrix X: +*> +*> [ B11 | B12 0 0 ] +*> [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**H +*> X = [-----------] = [---------] [----------------] [---------] . +*> [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ] +*> [ 0 | 0 0 I ] +*> +*> X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is +*> not the case, then X must be transposed and/or permuted. This can be +*> done in constant time using the TRANS and SIGNS options. See ZUNCSD +*> for details.) +*> +*> The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by- +*> (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are +*> represented implicitly by Householder vectors. +*> +*> B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER +*> = 'T': X, U1, U2, V1T, and V2T are stored in row-major +*> order; +*> otherwise: X, U1, U2, V1T, and V2T are stored in column- +*> major order. +*> \endverbatim +*> +*> \param[in] SIGNS +*> \verbatim +*> SIGNS is CHARACTER +*> = 'O': The lower-left block is made nonpositive (the +*> "other" convention); +*> otherwise: The upper-right block is made nonpositive (the +*> "default" convention). +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows and columns in X. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11 and X12. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top-left block of the unitary matrix to be +*> reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the columns of tril(X11) specify reflectors for P1, +*> the rows of triu(X11,1) specify reflectors for Q1; +*> else TRANS = 'T', and +*> the rows of triu(X11) specify reflectors for P1, +*> the columns of tril(X11,-1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. If TRANS = 'N', then LDX11 >= +*> P; else LDX11 >= Q. +*> \endverbatim +*> +*> \param[in,out] X12 +*> \verbatim +*> X12 is COMPLEX*16 array, dimension (LDX12,M-Q) +*> On entry, the top-right block of the unitary matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the rows of triu(X12) specify the first P reflectors for +*> Q2; +*> else TRANS = 'T', and +*> the columns of tril(X12) specify the first P reflectors +*> for Q2. +*> \endverbatim +*> +*> \param[in] LDX12 +*> \verbatim +*> LDX12 is INTEGER +*> The leading dimension of X12. If TRANS = 'N', then LDX12 >= +*> P; else LDX11 >= M-Q. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom-left block of the unitary matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the columns of tril(X21) specify reflectors for P2; +*> else TRANS = 'T', and +*> the rows of triu(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. If TRANS = 'N', then LDX21 >= +*> M-P; else LDX21 >= Q. +*> \endverbatim +*> +*> \param[in,out] X22 +*> \verbatim +*> X22 is COMPLEX*16 array, dimension (LDX22,M-Q) +*> On entry, the bottom-right block of the unitary matrix to +*> be reduced. On exit, the form depends on TRANS: +*> If TRANS = 'N', then +*> the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last +*> M-P-Q reflectors for Q2, +*> else TRANS = 'T', and +*> the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last +*> M-P-Q reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX22 +*> \verbatim +*> LDX22 is INTEGER +*> The leading dimension of X22. If TRANS = 'N', then LDX22 >= +*> M-P; else LDX22 >= M-Q. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B12, B21, B22 can +*> be computed from the angles THETA and PHI. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B12, B21, B22 can +*> be computed from the angles THETA and PHI. See Further +*> Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] TAUQ2 +*> \verbatim +*> TAUQ2 is COMPLEX*16 array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> Q2. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The bidiagonal blocks B11, B12, B21, and B22 are represented +*> implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ..., +*> PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are +*> lower bidiagonal. Every entry in each bidiagonal band is a product +*> of a sine or cosine of a THETA with a sine or cosine of a PHI. See +*> [1] or ZUNCSD for details. +*> +*> P1, P2, Q1, and Q2 are represented as products of elementary +*> reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2 +*> using ZUNGQR and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, + $ LDX12, + $ X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, + $ TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIGNS, TRANS + INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, + $ Q +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI( * ), THETA( * ) + COMPLEX*16 TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), + $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), + $ X21( LDX21, * ), X22( LDX22, * ) +* .. +* +* ==================================================================== +* +* .. Parameters .. + DOUBLE PRECISION REALONE + PARAMETER ( REALONE = 1.0D0 ) + COMPLEX*16 ONE + PARAMETER ( ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + LOGICAL COLMAJOR, LQUERY + INTEGER I, LWORKMIN, LWORKOPT + DOUBLE PRECISION Z1, Z2, Z3, Z4 +* .. +* .. External Subroutines .. + EXTERNAL ZAXPY, ZLARF1F, ZLARFGP, ZSCAL, + $ XERBLA + EXTERNAL ZLACGV +* +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + LOGICAL LSAME + EXTERNAL DZNRM2, LSAME +* .. +* .. Intrinsic Functions + INTRINSIC ATAN2, COS, MAX, MIN, SIN + INTRINSIC DCMPLX, DCONJG +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + COLMAJOR = .NOT. LSAME( TRANS, 'T' ) + IF( .NOT. LSAME( SIGNS, 'O' ) ) THEN + Z1 = REALONE + Z2 = REALONE + Z3 = REALONE + Z4 = REALONE + ELSE + Z1 = REALONE + Z2 = -REALONE + Z3 = REALONE + Z4 = -REALONE + END IF + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -3 + ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN + INFO = -4 + ELSE IF( Q .LT. 0 .OR. Q .GT. P .OR. Q .GT. M-P .OR. + $ Q .GT. M-Q ) THEN + INFO = -5 + ELSE IF( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -7 + ELSE IF( .NOT.COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN + INFO = -7 + ELSE IF( COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN + INFO = -9 + ELSE IF( .NOT.COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN + INFO = -9 + ELSE IF( COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -11 + ELSE IF( .NOT.COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN + INFO = -11 + ELSE IF( COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN + INFO = -13 + ELSE IF( .NOT.COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN + INFO = -13 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + LWORKOPT = M - Q + LWORKMIN = M - Q + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN + INFO = -21 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'xORBDB', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Handle column-major and row-major separately +* + IF( COLMAJOR ) THEN +* +* Reduce columns 1, ..., Q of X11, X12, X21, and X22 +* + DO I = 1, Q +* + IF( I .EQ. 1 ) THEN + CALL ZSCAL( P-I+1, DCMPLX( Z1, 0.0D0 ), X11(I,I), 1 ) + ELSE + CALL ZSCAL( P-I+1, DCMPLX( Z1*COS(PHI(I-1)), 0.0D0 ), + $ X11(I,I), 1 ) + CALL ZAXPY( P-I+1, DCMPLX( -Z1*Z3*Z4*SIN(PHI(I-1)), + $ 0.0D0 ), X12(I,I-1), 1, X11(I,I), 1 ) + END IF + IF( I .EQ. 1 ) THEN + CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I), + $ 1 ) + ELSE + CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)), + $ 0.0D0 ), + $ X21(I,I), 1 ) + CALL ZAXPY( M-P-I+1, DCMPLX( -Z2*Z3*Z4*SIN(PHI(I-1)), + $ 0.0D0 ), X22(I,I-1), 1, X21(I,I), 1 ) + END IF +* + THETA(I) = ATAN2( DZNRM2( M-P-I+1, X21(I,I), 1 ), + $ DZNRM2( P-I+1, X11(I,I), 1 ) ) +* + IF( P .GT. I ) THEN + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, + $ TAUP1(I) ) + ELSE IF ( P .EQ. I ) THEN + CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) ) + END IF + IF ( M-P .GT. I ) THEN + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, + $ TAUP2(I) ) + ELSE IF ( M-P .EQ. I ) THEN + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1, + $ TAUP2(I) ) + END IF +* + IF ( Q .GT. I ) THEN + CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, + $ CONJG(TAUP1(I)), X11(I,I+1), LDX11, + $ WORK ) + CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK ) + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL ZLARF1F( 'L', P-I+1, M-Q-I+1, X11(I,I), 1, + $ CONJG(TAUP1(I)), X12(I,I), LDX12, WORK ) + CALL ZLARF1F( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1, + $ CONJG(TAUP2(I)), X22(I,I), LDX22, WORK ) + END IF +* + IF( I .LT. Q ) THEN + CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), + $ 0.0D0 ), + $ X11(I,I+1), LDX11 ) + CALL ZAXPY( Q-I, DCMPLX( Z2*Z3*COS(THETA(I)), 0.0D0 ), + $ X21(I,I+1), LDX21, X11(I,I+1), LDX11 ) + END IF + CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)), + $ 0.0D0 ), + $ X12(I,I), LDX12 ) + CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)), + $ 0.0D0 ), + $ X22(I,I), LDX22, X12(I,I), LDX12 ) +* + IF( I .LT. Q ) + $ PHI(I) = ATAN2( DZNRM2( Q-I, X11(I,I+1), LDX11 ), + $ DZNRM2( M-Q-I+1, X12(I,I), LDX12 ) ) +* + IF( I .LT. Q ) THEN + CALL ZLACGV( Q-I, X11(I,I+1), LDX11 ) + IF ( I .EQ. Q-1 ) THEN + CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11, + $ TAUQ1(I) ) + ELSE + CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11, + $ TAUQ1(I) ) + END IF + END IF + IF ( M-Q+1 .GT. I ) THEN + CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) + IF ( M-Q .EQ. I ) THEN + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF + END IF +* + IF( I .LT. Q ) THEN + CALL ZLARF1F( 'R', P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK ) + CALL ZLARF1F( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, + $ TAUQ1(I), + $ X21(I+1,I+1), LDX21, WORK ) + END IF + IF ( P .GT. I ) THEN + CALL ZLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF ( M-P .GT. I ) THEN + CALL ZLARF1F( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(I+1,I), LDX22, WORK ) + END IF +* + IF( I .LT. Q ) + $ CALL ZLACGV( Q-I, X11(I,I+1), LDX11 ) + CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) +* + END DO +* +* Reduce columns Q + 1, ..., P of X12, X22 +* + DO I = Q + 1, P +* + CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I), + $ LDX12 ) + CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) + IF ( I .GE. M-Q ) THEN + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12, + $ TAUQ2(I) ) + ELSE + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12, + $ TAUQ2(I) ) + END IF +* + IF ( P .GT. I ) THEN + CALL ZLARF1F( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), + $ X12(I+1,I), LDX12, WORK ) + END IF + IF( M-P-Q .GE. 1 ) + $ CALL ZLARF1F( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12, + $ TAUQ2(I), X22(Q+1,I), LDX22, WORK ) +* + CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 ) +* + END DO +* +* Reduce columns P + 1, ..., M - Q of X12, X22 +* + DO I = 1, M - P - Q +* + CALL ZSCAL( M-P-Q-I+1, DCMPLX( Z2*Z4, 0.0D0 ), + $ X22(Q+I,P+I), LDX22 ) + CALL ZLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) + CALL ZLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1), + $ LDX22, TAUQ2(P+I) ) + CALL ZLARF1F( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), + $ LDX22, TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, + $ WORK ) +* + CALL ZLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 ) +* + END DO +* + ELSE +* +* Reduce columns 1, ..., Q of X11, X12, X21, X22 +* + DO I = 1, Q +* + IF( I .EQ. 1 ) THEN + CALL ZSCAL( P-I+1, DCMPLX( Z1, 0.0D0 ), X11(I,I), + $ LDX11 ) + ELSE + CALL ZSCAL( P-I+1, DCMPLX( Z1*COS(PHI(I-1)), 0.0D0 ), + $ X11(I,I), LDX11 ) + CALL ZAXPY( P-I+1, DCMPLX( -Z1*Z3*Z4*SIN(PHI(I-1)), + $ 0.0D0 ), X12(I-1,I), LDX12, X11(I,I), LDX11 ) + END IF + IF( I .EQ. 1 ) THEN + CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I), + $ LDX21 ) + ELSE + CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)), + $ 0.0D0 ), + $ X21(I,I), LDX21 ) + CALL ZAXPY( M-P-I+1, DCMPLX( -Z2*Z3*Z4*SIN(PHI(I-1)), + $ 0.0D0 ), X22(I-1,I), LDX22, X21(I,I), LDX21 ) + END IF +* + THETA(I) = ATAN2( DZNRM2( M-P-I+1, X21(I,I), LDX21 ), + $ DZNRM2( P-I+1, X11(I,I), LDX11 ) ) +* + CALL ZLACGV( P-I+1, X11(I,I), LDX11 ) + CALL ZLACGV( M-P-I+1, X21(I,I), LDX21 ) +* + CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, + $ TAUP1(I) ) + IF ( I .EQ. M-P ) THEN + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21, + $ TAUP2(I) ) + ELSE + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21, + $ TAUP2(I) ) + END IF +* + CALL ZLARF1F( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I), + $ X11(I+1,I), LDX11, WORK ) + CALL ZLARF1F( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, + $ TAUP1(I), + $ X12(I,I), LDX12, WORK ) + CALL ZLARF1F( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X21(I+1,I), LDX21, WORK ) + CALL ZLARF1F( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21, + $ TAUP2(I), X22(I,I), LDX22, WORK ) +* + CALL ZLACGV( P-I+1, X11(I,I), LDX11 ) + CALL ZLACGV( M-P-I+1, X21(I,I), LDX21 ) +* + IF( I .LT. Q ) THEN + CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), + $ 0.0D0 ), + $ X11(I+1,I), 1 ) + CALL ZAXPY( Q-I, DCMPLX( Z2*Z3*COS(THETA(I)), 0.0D0 ), + $ X21(I+1,I), 1, X11(I+1,I), 1 ) + END IF + CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)), + $ 0.0D0 ), + $ X12(I,I), 1 ) + CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)), + $ 0.0D0 ), + $ X22(I,I), 1, X12(I,I), 1 ) +* + IF( I .LT. Q ) + $ PHI(I) = ATAN2( DZNRM2( Q-I, X11(I+1,I), 1 ), + $ DZNRM2( M-Q-I+1, X12(I,I), 1 ) ) +* + IF( I .LT. Q ) THEN + CALL ZLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, + $ TAUQ1(I) ) + END IF + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) +* + IF( I .LT. Q ) THEN + CALL ZLARF1F( 'L', Q-I, P-I, X11(I+1,I), 1, + $ CONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, + $ WORK ) + CALL ZLARF1F( 'L', Q-I, M-P-I, X11(I+1,I), 1, + $ CONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, + $ WORK ) + END IF + CALL ZLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), + $ X12(I,I+1), LDX12, WORK ) + + IF ( M-P .GT. I ) THEN + CALL ZLARF1F( 'L', M-Q-I+1, M-P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,I+1), LDX22, + $ WORK ) + END IF +* + END DO +* +* Reduce columns Q + 1, ..., P of X12, X22 +* + DO I = Q + 1, P +* + CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I), + $ 1 ) + CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, + $ TAUQ2(I) ) +* + IF ( P .GT. I ) THEN + CALL ZLARF1F( 'L', M-Q-I+1, P-I, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X12(I,I+1), LDX12, + $ WORK ) + END IF + IF( M-P-Q .GE. 1 ) + $ CALL ZLARF1F( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1, + $ CONJG(TAUQ2(I)), X22(I,Q+1), LDX22, + $ WORK ) +* + END DO +* +* Reduce columns P + 1, ..., M - Q of X12, X22 +* + DO I = 1, M - P - Q +* + CALL ZSCAL( M-P-Q-I+1, DCMPLX( Z2*Z4, 0.0D0 ), + $ X22(P+I,Q+I), 1 ) + CALL ZLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1, + $ TAUQ2(P+I) ) + IF ( M-P-Q .NE. I ) THEN + CALL ZLARF1F( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), + $ 1, CONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), + $ LDX22, WORK ) + END IF +* + END DO +* + END IF +* + RETURN +* +* End of ZUNBDB +* + END + diff --git a/lapack-netlib/zunbdb1.f b/lapack-netlib/zunbdb1.f new file mode 100644 index 0000000000..d1e1933176 --- /dev/null +++ b/lapack-netlib/zunbdb1.f @@ -0,0 +1,327 @@ +*> \brief \b ZUNBDB1 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNBDB1 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> ZUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P, +*> M-P, or M-Q. Routines ZUNBDB2, ZUNBDB3, and ZUNBDB4 handle cases in +*> which Q is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= +*> MIN(P,M-P,M-Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +*> +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb1 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, + $ XERBLA + EXTERNAL ZLACGV +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-2 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB1', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., Q of X11 and X21 +* + DO I = 1, Q +* + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + THETA(I) = ATAN2( DBLE( X21(I,I) ), DBLE( X11(I,I) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) +* + IF( I .LT. Q ) THEN + CALL ZDROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, + $ S ) + CALL ZLACGV( Q-I, X21(I,I+1), LDX21 ) + CALL ZLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, + $ TAUQ1(I) ) + S = DBLE( X21(I,I+1) ) + CALL ZLARF1F( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, + $ TAUQ1(I), X21(I+1,I+1), LDX21, + $ WORK(ILARF) ) + CALL ZLACGV( Q-I, X21(I,I+1), LDX21 ) + C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1 )**2 + $ + DZNRM2( M-P-I, X21(I+1,I+1), 1 )**2 ) + PHI(I) = ATAN2( S, C ) + CALL ZUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1, + $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11, + $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5, + $ CHILDINFO ) + END IF +* + END DO +* + RETURN +* +* End of ZUNBDB1 +* + END + diff --git a/lapack-netlib/zunbdb2.f b/lapack-netlib/zunbdb2.f new file mode 100644 index 0000000000..f8bc474f3e --- /dev/null +++ b/lapack-netlib/zunbdb2.f @@ -0,0 +1,334 @@ +*> \brief \b ZUNBDB2 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNBDB2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> ZUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P, +*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB3, and ZUNBDB4 handle cases in +*> which P is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by +*> angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P-1) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb2 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 NEGONE, ONE + PARAMETER ( NEGONE = (-1.0D0,0.0D0), + $ ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, + $ ZLACGV, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN + INFO = -2 + ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P-1, M-P, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB2', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., P of X11 and X21 +* + DO I = 1, P +* + IF( I .GT. 1 ) THEN + CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, + $ S ) + END IF + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + C = DBLE( X11(I,I) ) + CALL ZLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, + $ TAUQ1(I), X21(I,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + S = SQRT( DZNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DZNRM2( M-P-I+1, X21(I,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL ZUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1, + $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL ZSCAL( P-I, NEGONE, X11(I+1,I), 1 ) + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + IF( I .LT. P ) THEN + CALL ZLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) ) + PHI(I) = ATAN2( DBLE( X11(I+1,I) ), DBLE( X21(I,I) ) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + CALL ZLARF1F( 'L', P-I, Q-I, X11(I+1,I), 1, + $ CONJG(TAUP1(I)), + $ X11(I+1,I+1), LDX11, WORK(ILARF) ) + END IF + CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) +* + END DO +* +* Reduce the bottom-right portion of X21 to the identity matrix +* + DO I = P + 1, Q + CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) ) + CALL ZLARF1F( 'L', M-P-I+1, Q-I, X21(I,I), 1, + $ CONJG(TAUP2(I)), X21(I,I+1), LDX21, + $ WORK(ILARF) ) + END DO +* + RETURN +* +* End of ZUNBDB2 +* + END + diff --git a/lapack-netlib/zunbdb3.f b/lapack-netlib/zunbdb3.f new file mode 100644 index 0000000000..f7a9768946 --- /dev/null +++ b/lapack-netlib/zunbdb3.f @@ -0,0 +1,329 @@ +*> \brief \b ZUNBDB3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNBDB3 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), +* $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> ZUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P, +*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB4 handle cases in +*> which M-P is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q). +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M. +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (P) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-P) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*), + $ X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = (1.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5, + $ LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, ZLACGV, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN + INFO = -2 + ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( P, M-P-1, Q-1 ) + IORBDB5 = 2 + LORBDB5 = Q-1 + LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB3', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce rows 1, ..., M-P of X11 and X21 +* + DO I = 1, M-P +* + IF( I .GT. 1 ) THEN + CALL ZDROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, + $ S ) + END IF +* + CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + S = DBLE( X21(I,I) ) + CALL ZLARF1F( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I,I), LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + C = SQRT( DZNRM2( P-I+1, X11(I,I), 1 )**2 + $ + DZNRM2( M-P-I, X21(I+1,I), 1 )**2 ) + THETA(I) = ATAN2( S, C ) +* + CALL ZUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1, + $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21, + $ WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + IF( I .LT. M-P ) THEN + CALL ZLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, + $ TAUP2(I) ) + PHI(I) = ATAN2( DBLE( X21(I+1,I) ), DBLE( X11(I,I) ) ) + C = COS( PHI(I) ) + S = SIN( PHI(I) ) + CALL ZLARF1F( 'L', M-P-I, Q-I, X21(I+1,I), 1, + $ CONJG(TAUP2(I)), + $ X21(I+1,I+1), LDX21, WORK(ILARF) ) + END IF + CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + END DO +* +* Reduce the bottom-right portion of X11 to the identity matrix +* + DO I = M-P + 1, Q + CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) ) + CALL ZLARF1F( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)), + $ X11(I,I+1), LDX11, WORK(ILARF) ) + END DO +* + RETURN +* +* End of ZUNBDB3 +* + END + diff --git a/lapack-netlib/zunbdb4.f b/lapack-netlib/zunbdb4.f new file mode 100644 index 0000000000..31d8ec40b7 --- /dev/null +++ b/lapack-netlib/zunbdb4.f @@ -0,0 +1,384 @@ +*> \brief \b ZUNBDB4 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNBDB4 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, +* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, +* INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. +* DOUBLE PRECISION PHI(*), THETA(*) +* COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), +* $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*>\verbatim +*> +*> ZUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny +*> matrix X with orthonormal columns: +*> +*> [ B11 ] +*> [ X11 ] [ P1 | ] [ 0 ] +*> [-----] = [---------] [-----] Q1**T . +*> [ X21 ] [ | P2 ] [ B21 ] +*> [ 0 ] +*> +*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P, +*> M-P, or Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB3 handle cases in +*> which M-Q is not the minimum dimension. +*> +*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P), +*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by +*> Householder vectors. +*> +*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented +*> implicitly by angles THETA, PHI. +*> +*>\endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows X11 plus the number of rows in X21. +*> \endverbatim +*> +*> \param[in] P +*> \verbatim +*> P is INTEGER +*> The number of rows in X11. 0 <= P <= M. +*> \endverbatim +*> +*> \param[in] Q +*> \verbatim +*> Q is INTEGER +*> The number of columns in X11 and X21. 0 <= Q <= M and +*> M-Q <= min(P,M-P,Q). +*> \endverbatim +*> +*> \param[in,out] X11 +*> \verbatim +*> X11 is COMPLEX*16 array, dimension (LDX11,Q) +*> On entry, the top block of the matrix X to be reduced. On +*> exit, the columns of tril(X11) specify reflectors for P1 and +*> the rows of triu(X11,1) specify reflectors for Q1. +*> \endverbatim +*> +*> \param[in] LDX11 +*> \verbatim +*> LDX11 is INTEGER +*> The leading dimension of X11. LDX11 >= P. +*> \endverbatim +*> +*> \param[in,out] X21 +*> \verbatim +*> X21 is COMPLEX*16 array, dimension (LDX21,Q) +*> On entry, the bottom block of the matrix X to be reduced. On +*> exit, the columns of tril(X21) specify reflectors for P2. +*> \endverbatim +*> +*> \param[in] LDX21 +*> \verbatim +*> LDX21 is INTEGER +*> The leading dimension of X21. LDX21 >= M-P. +*> \endverbatim +*> +*> \param[out] THETA +*> \verbatim +*> THETA is DOUBLE PRECISION array, dimension (Q) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] PHI +*> \verbatim +*> PHI is DOUBLE PRECISION array, dimension (Q-1) +*> The entries of the bidiagonal blocks B11, B21 are defined by +*> THETA and PHI. See Further Details. +*> \endverbatim +*> +*> \param[out] TAUP1 +*> \verbatim +*> TAUP1 is COMPLEX*16 array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> P1. +*> \endverbatim +*> +*> \param[out] TAUP2 +*> \verbatim +*> TAUP2 is COMPLEX*16 array, dimension (M-Q) +*> The scalar factors of the elementary reflectors that define +*> P2. +*> \endverbatim +*> +*> \param[out] TAUQ1 +*> \verbatim +*> TAUQ1 is COMPLEX*16 array, dimension (Q) +*> The scalar factors of the elementary reflectors that define +*> Q1. +*> \endverbatim +*> +*> \param[out] PHANTOM +*> \verbatim +*> PHANTOM is COMPLEX*16 array, dimension (M) +*> The routine computes an M-by-1 column vector Y that is +*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and +*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and +*> Y(P+1:M), respectively. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. LWORK >= M-Q. +*> +*> If LWORK = -1, then a workspace query is assumed; the routine +*> only calculates the optimal size of the WORK array, returns +*> this value as the first entry of the WORK array, and no error +*> message related to LWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unbdb4 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> The upper-bidiagonal blocks B11, B21 are represented implicitly by +*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry +*> in each bidiagonal band is a product of a sine or cosine of a THETA +*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details. +*> +*> P1, P2, and Q1 are represented as products of elementary reflectors. +*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR +*> and ZUNGLQ. +*> \endverbatim +* +*> \par References: +* ================ +*> +*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. +*> Algorithms, 50(1):33-65, 2009. +*> +* ===================================================================== + SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, + $ PHI, + $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, LWORK, M, P, Q, LDX11, LDX21 +* .. +* .. Array Arguments .. + DOUBLE PRECISION PHI(*), THETA(*) + COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*), + $ WORK(*), X11(LDX11,*), X21(LDX21,*) +* .. +* +* ==================================================================== +* +* .. Parameters .. + COMPLEX*16 NEGONE, ONE, ZERO + PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0), + $ ZERO = (0.0D0,0.0D0) ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION C, S + INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF, + $ LORBDB5, LWORKMIN, LWORKOPT + LOGICAL LQUERY +* .. +* .. External Subroutines .. + EXTERNAL ZLARF1F, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, + $ ZLACGV, + $ XERBLA +* .. +* .. External Functions .. + DOUBLE PRECISION DZNRM2 + EXTERNAL DZNRM2 +* .. +* .. Intrinsic Function .. + INTRINSIC ATAN2, COS, MAX, SIN, SQRT +* .. +* .. Executable Statements .. +* +* Test input arguments +* + INFO = 0 + LQUERY = LWORK .EQ. -1 +* + IF( M .LT. 0 ) THEN + INFO = -1 + ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN + INFO = -2 + ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN + INFO = -3 + ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN + INFO = -5 + ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN + INFO = -7 + END IF +* +* Compute workspace +* + IF( INFO .EQ. 0 ) THEN + ILARF = 2 + LLARF = MAX( Q-1, P-1, M-P-1 ) + IORBDB5 = 2 + LORBDB5 = Q + LWORKOPT = ILARF + LLARF - 1 + LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 ) + LWORKMIN = LWORKOPT + WORK(1) = LWORKOPT + IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN + INFO = -14 + END IF + END IF + IF( INFO .NE. 0 ) THEN + CALL XERBLA( 'ZUNBDB4', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Reduce columns 1, ..., M-Q of X11 and X21 +* + DO I = 1, M-Q +* + IF( I .EQ. 1 ) THEN + DO J = 1, M + PHANTOM(J) = ZERO + END DO + CALL ZUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1, + $ X11, LDX11, X21, LDX21, WORK(IORBDB5), + $ LORBDB5, CHILDINFO ) + CALL ZSCAL( P, NEGONE, PHANTOM(1), 1 ) + CALL ZLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) ) + CALL ZLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, + $ TAUP2(1) ) + THETA(I) = ATAN2( DBLE( PHANTOM(1) ), DBLE( PHANTOM(P+1) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + CALL ZLARF1F( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), + $ X11, + $ LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'L', M-P, Q, PHANTOM(P+1), 1, + $ CONJG(TAUP2(1)), + $ X21, LDX21, WORK(ILARF) ) + ELSE + CALL ZUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1, + $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I), + $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO ) + CALL ZSCAL( P-I+1, NEGONE, X11(I,I-1), 1 ) + CALL ZLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, + $ TAUP1(I) ) + CALL ZLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1, + $ TAUP2(I) ) + THETA(I) = ATAN2( DBLE( X11(I,I-1) ), DBLE( X21(I,I-1) ) ) + C = COS( THETA(I) ) + S = SIN( THETA(I) ) + CALL ZLARF1F( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, + $ CONJG(TAUP1(I)), X11(I,I), LDX11, + $ WORK(ILARF) ) + CALL ZLARF1F( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, + $ CONJG(TAUP2(I)), X21(I,I), LDX21, + $ WORK(ILARF) ) + END IF +* + CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C ) + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) ) + C = DBLE( X21(I,I) ) + CALL ZLARF1F( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I), + $ X21(I+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X21(I,I), LDX21 ) + IF( I .LT. M-Q ) THEN + S = SQRT( DZNRM2( P-I, X11(I+1,I), 1 )**2 + $ + DZNRM2( M-P-I, X21(I+1,I), 1 )**2 ) + PHI(I) = ATAN2( S, C ) + END IF +* + END DO +* +* Reduce the bottom-right portion of X11 to [ I 0 ] +* + DO I = M - Q + 1, P + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) ) + CALL ZLARF1F( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X11(I+1,I), LDX11, WORK(ILARF) ) + CALL ZLARF1F( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I), + $ X21(M-Q+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X11(I,I), LDX11 ) + END DO +* +* Reduce the bottom-right portion of X21 to [ 0 I ] +* + DO I = P + 1, Q + CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) + CALL ZLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), + $ LDX21, + $ TAUQ1(I) ) + CALL ZLARF1F( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, + $ TAUQ1(I), + $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) ) + CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 ) + END DO +* + RETURN +* +* End of ZUNBDB4 +* + END + diff --git a/lapack-netlib/zung2l.f b/lapack-netlib/zung2l.f new file mode 100644 index 0000000000..7f5cf64b00 --- /dev/null +++ b/lapack-netlib/zung2l.f @@ -0,0 +1,196 @@ +*> \brief \b ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNG2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNG2L generates an m by n complex matrix Q with orthonormal columns, +*> which is defined as the last n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by ZGEQLF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the (n-k+i)-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by ZGEQLF in the last k columns of its array +*> argument A. +*> On exit, the m-by-n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQLF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ung2l +* +* ===================================================================== + SUBROUTINE ZUNG2L( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1L, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNG2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns 1:n-k to columns of the unit matrix +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left +* + A( M-N+II, II ) = ONE + CALL ZLARF1L( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), + $ A, + $ LDA, WORK ) + CALL ZSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* Set A(m-k+i+1:m,n-k+i) to zero +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2L +* + END diff --git a/lapack-netlib/zung2r.f b/lapack-netlib/zung2r.f new file mode 100644 index 0000000000..56374be425 --- /dev/null +++ b/lapack-netlib/zung2r.f @@ -0,0 +1,196 @@ +*> \brief \b ZUNG2R +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNG2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNG2R generates an m by n complex matrix Q with orthonormal columns, +*> which is defined as the first n columns of a product of k elementary +*> reflectors of order m +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by ZGEQRF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. M >= N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. N >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the i-th column must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by ZGEQRF in the first k columns of its array +*> argument A. +*> On exit, the m by n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQRF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (N) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ung2r +* +* ===================================================================== + SUBROUTINE ZUNG2R( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1F, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + CALL ZLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL ZSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNG2R +* + END diff --git a/lapack-netlib/zungl2.f b/lapack-netlib/zungl2.f new file mode 100644 index 0000000000..24f41b9be8 --- /dev/null +++ b/lapack-netlib/zungl2.f @@ -0,0 +1,203 @@ +*> \brief \b ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNGL2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNGL2 generates an m-by-n complex matrix Q with orthonormal rows, +*> which is defined as the first m rows of a product of k elementary +*> reflectors of order n +*> +*> Q = H(k)**H . . . H(2)**H H(1)**H +*> +*> as returned by ZGELQF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. M >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the i-th row must contain the vector which defines +*> the elementary reflector H(i), for i = 1,2,...,k, as returned +*> by ZGELQF in the first k rows of its array argument A. +*> On exit, the m by n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGELQF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ungl2 +* +* ===================================================================== + SUBROUTINE ZUNGL2( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1F, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGL2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) + $ RETURN +* + IF( K.LT.M ) THEN +* +* Initialise rows k+1:m to rows of the unit matrix +* + DO 20 J = 1, N + DO 10 L = K + 1, M + A( L, J ) = ZERO + 10 CONTINUE + IF( J.GT.K .AND. J.LE.M ) + $ A( J, J ) = ONE + 20 CONTINUE + END IF +* + DO 40 I = K, 1, -1 +* +* Apply H(i)**H to A(i:m,i:n) from the right +* + IF( I.LT.N ) THEN + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + IF( I.LT.M ) THEN + CALL ZLARF1F( 'Right', M-I, N-I+1, A( I, I ), LDA, + $ CONJG( TAU( I ) ), A( I+1, I ), LDA, + $ WORK ) + END IF + CALL ZSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) + CALL ZLACGV( N-I, A( I, I+1 ), LDA ) + END IF + A( I, I ) = ONE - DCONJG( TAU( I ) ) +* +* Set A(i,1:i-1) to zero +* + DO 30 L = 1, I - 1 + A( I, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNGL2 +* + END diff --git a/lapack-netlib/zungr2.f b/lapack-netlib/zungr2.f new file mode 100644 index 0000000000..f24a455fe6 --- /dev/null +++ b/lapack-netlib/zungr2.f @@ -0,0 +1,200 @@ +*> \brief \b ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNGR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNGR2 generates an m by n complex matrix Q with orthonormal rows, +*> which is defined as the last m rows of a product of k elementary +*> reflectors of order n +*> +*> Q = H(1)**H H(2)**H . . . H(k)**H +*> +*> as returned by ZGERQF. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix Q. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix Q. N >= M. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines the +*> matrix Q. M >= K >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> On entry, the (m-k+i)-th row must contain the vector which +*> defines the elementary reflector H(i), for i = 1,2,...,k, as +*> returned by ZGERQF in the last k rows of its array argument +*> A. +*> On exit, the m-by-n matrix Q. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The first dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGERQF. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (M) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument has an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup ungr2 +* +* ===================================================================== + SUBROUTINE ZUNGR2( M, N, K, A, LDA, TAU, WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- 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, K, LDA, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE, ZERO + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), + $ ZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1L, ZSCAL +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.M ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNGR2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.LE.0 ) + $ RETURN +* + IF( K.LT.M ) THEN +* +* Initialise rows 1:m-k to rows of the unit matrix +* + DO 20 J = 1, N + DO 10 L = 1, M - K + A( L, J ) = ZERO + 10 CONTINUE + IF( J.GT.N-M .AND. J.LE.N-K ) + $ A( M-N+J, J ) = ONE + 20 CONTINUE + END IF +* + DO 40 I = 1, K + II = M - K + I +* +* Apply H(i)**H to A(1:m-k+i,1:n-k+i) from the right +* + CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA ) + CALL ZLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA, + $ CONJG( TAU( I ) ), A, LDA, WORK ) + CALL ZSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA ) + CALL ZLACGV( N-M+II-1, A( II, 1 ), LDA ) + A( II, N-M+II ) = ONE - DCONJG( TAU( I ) ) +* +* Set A(m-k+i,n-k+i+1:n) to zero +* + DO 30 L = N - M + II + 1, N + A( II, L ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of ZUNGR2 +* + END diff --git a/lapack-netlib/zunm2l.f b/lapack-netlib/zunm2l.f new file mode 100644 index 0000000000..2756bf9811 --- /dev/null +++ b/lapack-netlib/zunm2l.f @@ -0,0 +1,275 @@ +*> \brief \b ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNM2L + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNM2L overwrites the general complex m-by-n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**H* C if SIDE = 'L' and TRANS = 'C', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**H if SIDE = 'R' and TRANS = 'C', +*> +*> where Q is a complex unitary matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(k) . . . H(2) H(1) +*> +*> as returned by ZGEQLF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left +*> = 'R': apply Q or Q**H from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'C': apply Q**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> ZGEQLF in the last k columns of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQLF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m-by-n matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unm2l +* +* ===================================================================== + SUBROUTINE ZUNM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + COMPLEX*16 TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1L +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNM2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) +* + MI = M - K + I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) +* + NI = N - K + I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + CALL ZLARF1L( SIDE, MI, NI, A( 1, I ), 1, TAUI, C, LDC, + $ WORK ) + 10 CONTINUE + RETURN +* +* End of ZUNM2L +* + END diff --git a/lapack-netlib/zunm2r.f b/lapack-netlib/zunm2r.f new file mode 100644 index 0000000000..8e42228a7f --- /dev/null +++ b/lapack-netlib/zunm2r.f @@ -0,0 +1,280 @@ +*> \brief \b ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNM2R + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNM2R overwrites the general complex m-by-n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**H* C if SIDE = 'L' and TRANS = 'C', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**H if SIDE = 'R' and TRANS = 'C', +*> +*> where Q is a complex unitary matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1) H(2) . . . H(k) +*> +*> as returned by ZGEQRF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left +*> = 'R': apply Q or Q**H from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'C': apply Q**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,K) +*> The i-th column must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> ZGEQRF in the first k columns of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. +*> If SIDE = 'L', LDA >= max(1,M); +*> if SIDE = 'R', LDA >= max(1,N). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGEQRF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m-by-n matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unm2r +* +* ===================================================================== + SUBROUTINE ZUNM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1F +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNM2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + CALL ZLARF1F( SIDE, MI, NI, A( I, I ), 1, TAUI, C( IC, JC ), + $ LDC, + $ WORK ) + 10 CONTINUE + RETURN +* +* End of ZUNM2R +* + END diff --git a/lapack-netlib/zunml2.f b/lapack-netlib/zunml2.f new file mode 100644 index 0000000000..969d586d17 --- /dev/null +++ b/lapack-netlib/zunml2.f @@ -0,0 +1,283 @@ +*> \brief \b ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNML2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNML2 overwrites the general complex m-by-n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**H* C if SIDE = 'L' and TRANS = 'C', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**H if SIDE = 'R' and TRANS = 'C', +*> +*> where Q is a complex unitary matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(k)**H . . . H(2)**H H(1)**H +*> +*> as returned by ZGELQF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left +*> = 'R': apply Q or Q**H from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'C': apply Q**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> ZGELQF in the first k rows of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGELQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m-by-n matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unml2 +* +* ===================================================================== + SUBROUTINE ZUNML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + COMPLEX*16 TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1F +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNML2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN .OR. .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(i:m,1:n) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,i:n) +* + NI = N - I + 1 + JC = I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = DCONJG( TAU( I ) ) + ELSE + TAUI = TAU( I ) + END IF + IF( I.LT.NQ ) + $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) + CALL ZLARF1F( SIDE, MI, NI, A( I, I ), LDA, TAUI, C( IC, + $ JC ), LDC, WORK ) + IF( I.LT.NQ ) + $ CALL ZLACGV( NQ-I, A( I, I+1 ), LDA ) + 10 CONTINUE + RETURN +* +* End of ZUNML2 +* + END diff --git a/lapack-netlib/zunmr2.f b/lapack-netlib/zunmr2.f new file mode 100644 index 0000000000..6696a7f8f2 --- /dev/null +++ b/lapack-netlib/zunmr2.f @@ -0,0 +1,277 @@ +*> \brief \b ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf (unblocked algorithm). +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUNMR2 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, +* WORK, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS +* INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUNMR2 overwrites the general complex m-by-n matrix C with +*> +*> Q * C if SIDE = 'L' and TRANS = 'N', or +*> +*> Q**H* C if SIDE = 'L' and TRANS = 'C', or +*> +*> C * Q if SIDE = 'R' and TRANS = 'N', or +*> +*> C * Q**H if SIDE = 'R' and TRANS = 'C', +*> +*> where Q is a complex unitary matrix defined as the product of k +*> elementary reflectors +*> +*> Q = H(1)**H H(2)**H . . . H(k)**H +*> +*> as returned by ZGERQF. Q is of order m if SIDE = 'L' and of order n +*> if SIDE = 'R'. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left +*> = 'R': apply Q or Q**H from the Right +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': apply Q (No transpose) +*> = 'C': apply Q**H (Conjugate transpose) +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> The number of elementary reflectors whose product defines +*> the matrix Q. +*> If SIDE = 'L', M >= K >= 0; +*> if SIDE = 'R', N >= K >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension +*> (LDA,M) if SIDE = 'L', +*> (LDA,N) if SIDE = 'R' +*> The i-th row must contain the vector which defines the +*> elementary reflector H(i), for i = 1,2,...,k, as returned by +*> ZGERQF in the last k rows of its array argument A. +*> A is modified by the routine but restored on exit. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,K). +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (K) +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZGERQF. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the m-by-n matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L', +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup unmr2 +* +* ===================================================================== + SUBROUTINE ZUNMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + COMPLEX*16 TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLACGV, ZLARF1L +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, K ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUNMR2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(1:m-k+i,1:n) +* + MI = M - K + I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,1:n-k+i) +* + NI = N - K + I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = DCONJG( TAU( I ) ) + ELSE + TAUI = TAU( I ) + END IF + CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA ) + CALL ZLARF1L( SIDE, MI, NI, A( I, 1 ), LDA, TAUI, C, LDC, + $ WORK ) + CALL ZLACGV( NQ-K+I-1, A( I, 1 ), LDA ) + 10 CONTINUE + RETURN +* +* End of ZUNMR2 +* + END diff --git a/lapack-netlib/zupmtr.f b/lapack-netlib/zupmtr.f new file mode 100644 index 0000000000..b37f4b182d --- /dev/null +++ b/lapack-netlib/zupmtr.f @@ -0,0 +1,340 @@ +*> \brief \b ZUPMTR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> Download ZUPMTR + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +* +* Definition: +* =========== +* +* SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, +* INFO ) +* +* .. Scalar Arguments .. +* CHARACTER SIDE, TRANS, UPLO +* INTEGER INFO, LDC, M, N +* .. +* .. Array Arguments .. +* COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZUPMTR overwrites the general complex M-by-N matrix C with +*> +*> SIDE = 'L' SIDE = 'R' +*> TRANS = 'N': Q * C C * Q +*> TRANS = 'C': Q**H * C C * Q**H +*> +*> where Q is a complex unitary matrix of order nq, with nq = m if +*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of +*> nq-1 elementary reflectors, as returned by ZHPTRD using packed +*> storage: +*> +*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); +*> +*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SIDE +*> \verbatim +*> SIDE is CHARACTER*1 +*> = 'L': apply Q or Q**H from the Left; +*> = 'R': apply Q or Q**H from the Right. +*> \endverbatim +*> +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> = 'U': Upper triangular packed storage used in previous +*> call to ZHPTRD; +*> = 'L': Lower triangular packed storage used in previous +*> call to ZHPTRD. +*> \endverbatim +*> +*> \param[in] TRANS +*> \verbatim +*> TRANS is CHARACTER*1 +*> = 'N': No transpose, apply Q; +*> = 'C': Conjugate transpose, apply Q**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix C. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix C. N >= 0. +*> \endverbatim +*> +*> \param[in] AP +*> \verbatim +*> AP is COMPLEX*16 array, dimension +*> (M*(M+1)/2) if SIDE = 'L' +*> (N*(N+1)/2) if SIDE = 'R' +*> The vectors which define the elementary reflectors, as +*> returned by ZHPTRD. AP is modified by the routine but +*> restored on exit. +*> \endverbatim +*> +*> \param[in] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (M-1) if SIDE = 'L' +*> or (N-1) if SIDE = 'R' +*> TAU(i) must contain the scalar factor of the elementary +*> reflector H(i), as returned by ZHPTRD. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> On entry, the M-by-N matrix C. +*> On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension +*> (N) if SIDE = 'L' +*> (M) if SIDE = 'R' +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit +*> < 0: if INFO = -i, the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup upmtr +* +* ===================================================================== + SUBROUTINE ZUPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, + $ WORK, + $ INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDC, M, N +* .. +* .. Array Arguments .. + COMPLEX*16 AP( * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + LOGICAL FORWRD, LEFT, NOTRAN, UPPER + INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ + COMPLEX*16 TAUI +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA, ZLARF1, ZLARF1F +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) + UPPER = LSAME( UPLO, 'U' ) +* +* NQ is the order of Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZUPMTR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Q was determined by a call to ZHPTRD with UPLO = 'U' +* + FORWRD = ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) +* + IF( FORWRD ) THEN + I1 = 1 + I2 = NQ - 1 + I3 = 1 + II = 2 + ELSE + I1 = NQ - 1 + I2 = 1 + I3 = -1 + II = NQ*( NQ+1 ) / 2 - 1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(1:i,1:n) +* + MI = I + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,1:i) +* + NI = I + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + CALL ZLARF1L( SIDE, MI, NI, AP( II-I+1 ), 1, TAUI, C, + $ LDC, WORK ) +* + IF( FORWRD ) THEN + II = II + I + 2 + ELSE + II = II - I - 1 + END IF + 10 CONTINUE + ELSE +* +* Q was determined by a call to ZHPTRD with UPLO = 'L'. +* + FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) +* + IF( FORWRD ) THEN + I1 = 1 + I2 = NQ - 1 + I3 = 1 + II = 2 + ELSE + I1 = NQ - 1 + I2 = 1 + I3 = -1 + II = NQ*( NQ+1 ) / 2 - 1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 20 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(i) or H(i)**H is applied to C(i+1:m,1:n) +* + MI = M - I + IC = I + 1 + ELSE +* +* H(i) or H(i)**H is applied to C(1:m,i+1:n) +* + NI = N - I + JC = I + 1 + END IF +* +* Apply H(i) or H(i)**H +* + IF( NOTRAN ) THEN + TAUI = TAU( I ) + ELSE + TAUI = DCONJG( TAU( I ) ) + END IF + CALL ZLARF1F( SIDE, MI, NI, AP( II ), 1, TAUI, C( IC, + $ JC ), LDC, WORK ) +* + IF( FORWRD ) THEN + II = II + NQ - I + 1 + ELSE + II = II - NQ + I - 2 + END IF + 20 CONTINUE + END IF + RETURN +* +* End of ZUPMTR +* + END