slaqtr.f slar1v.f slar2v.f ilaslr.f ilaslc.f
slarf.f slarfb.f slarfg.f slarfgp.f slarft.f slarfx.f slargv.f
slarrv.f slartv.f
- slarz.f slarzb.f slarzt.f slaswp.f slasy2.f slasyf.f slasyf_rook.f slasyf_aa.f
+ slarz.f slarzb.f slarzt.f slaswp.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
slauu2.f slauum.f sopgtr.f sopmtr.f sorg2l.f sorg2r.f
sorgbr.f sorghr.f sorgl2.f sorglq.f sorgql.f sorgqr.f sorgr2.f
sstevx.f ssycon.f ssyev.f ssyevd.f ssyevr.f ssyevx.f ssygs2.f
ssygst.f ssygv.f ssygvd.f ssygvx.f ssyrfs.f ssysv.f ssysvx.f
ssytd2.f ssytf2.f ssytrd.f ssytrf.f ssytri.f ssytri2.f ssytri2x.f
- ssyswapr.f ssytrs.f ssytrs2.f ssyconv.f
+ ssyswapr.f ssytrs.f ssytrs2.f
+ ssyconv.f ssyconvf.f ssyconvf_rook.f
ssysv_aa.f ssytrf_aa.f ssytrs_aa.f
ssytf2_rook.f ssytrf_rook.f ssytrs_rook.f
ssytri_rook.f ssycon_rook.f ssysv_rook.f
+ ssytf2_rk.f ssytrf_rk.f ssytrs_3.f
+ ssytri_3.f ssytri_3x.f ssycon_3.f ssysv_rk.f
+ ssysv_aa.f ssytrf_aa.f ssytrs_aa.f
stbcon.f
stbrfs.f stbtrs.f stgevc.f stgex2.f stgexc.f stgsen.f
stgsja.f stgsna.f stgsy2.f stgsyl.f stpcon.f stprfs.f stptri.f
chetf2.f chetrd.f
chetrf.f chetri.f chetri2.f chetri2x.f cheswapr.f
chetrs.f chetrs2.f
+ chetf2_rook.f chetrf_rook.f chetri_rook.f
+ chetrs_rook.f checon_rook.f chesv_rook.f
+ chetf2_rk.f chetrf_rk.f chetri_3.f chetri_3x.f
+ chetrs_3.f checon_3.f chesv_rk.f
chesv_aa.f chetrf_aa.f chetrs_aa.f
- chetf2_rook.f chetrf_rook.f chetri_rook.f chetrs_rook.f checon_rook.f chesv_rook.f
chgeqz.f chpcon.f chpev.f chpevd.f
chpevx.f chpgst.f chpgv.f chpgvd.f chpgvx.f chprfs.f chpsv.f
chpsvx.f
clacgv.f clacon.f clacn2.f clacp2.f clacpy.f clacrm.f clacrt.f cladiv.f
claed0.f claed7.f claed8.f
claein.f claesy.f claev2.f clags2.f clagtm.f
- clahef.f clahef_rook.f clahef_aa.f clahqr.f
+ clahef.f clahef_rook.f clahef_rk.f clahef_aa.f clahqr.f
clahr2.f claic1.f clals0.f clalsa.f clalsd.f clangb.f clange.f clangt.f
clanhb.f clanhe.f
clanhp.f clanhs.f clanht.f clansb.f clansp.f clansy.f clantb.f
clarf.f clarfb.f clarfg.f clarfgp.f clarft.f
clarfx.f clargv.f clarnv.f clarrv.f clartg.f clartv.f
clarz.f clarzb.f clarzt.f clascl.f claset.f clasr.f classq.f
- claswp.f clasyf.f clasyf_rook.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f
+ claswp.f clasyf.f clasyf_rook.f clasyf_rk.f clatbs.f clatdf.f clatps.f clatrd.f clatrs.f clatrz.f
clauu2.f clauum.f cpbcon.f cpbequ.f cpbrfs.f cpbstf.f cpbsv.f
cpbsvx.f cpbtf2.f cpbtrf.f cpbtrs.f cpocon.f cpoequ.f cporfs.f
cposv.f cposvx.f cpotf2.f cpotrf.f cpotrf2.f cpotri.f cpotrs.f cpstrf.f cpstf2.f
cstegr.f cstein.f csteqr.f csycon.f csymv.f
csyr.f csyrfs.f csysv.f csysvx.f csytf2.f csytrf.f csytri.f
csytri2.f csytri2x.f csyswapr.f
- csytrs.f csytrs2.f csyconv.f
+ csytrs.f csytrs2.f
+ csyconv.f csyconvf.f csyconvf_rook.f
csytf2_rook.f csytrf_rook.f csytrs_rook.f
csytri_rook.f csycon_rook.f csysv_rook.f
+ csytf2_rk.f csytrf_rk.f csytrs_3.f
+ csytri_3.f csytri_3x.f csycon_3.f csysv_rk.f
ctbcon.f ctbrfs.f ctbtrs.f ctgevc.f ctgex2.f
ctgexc.f ctgsen.f ctgsja.f ctgsna.f ctgsy2.f ctgsyl.f ctpcon.f
ctprfs.f ctptri.f
dlaqtr.f dlar1v.f dlar2v.f iladlr.f iladlc.f
dlarf.f dlarfb.f dlarfg.f dlarfgp.f dlarft.f dlarfx.f dlargv.f
dlarrv.f dlartv.f
- dlarz.f dlarzb.f dlarzt.f dlaswp.f dlasy2.f dlasyf.f dlasyf_rook.f dlasyf_aa.f
+ dlarz.f dlarzb.f dlarzt.f dlaswp.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 dlauu2.f
dlauum.f dopgtr.f dopmtr.f dorg2l.f dorg2r.f
dorgbr.f dorghr.f dorgl2.f dorglq.f dorgql.f dorgqr.f dorgr2.f
dsyevx.f dsygs2.f dsygst.f dsygv.f dsygvd.f dsygvx.f dsyrfs.f
dsysv.f dsysvx.f
dsytd2.f dsytf2.f dsytrd.f dsytrf.f dsytri.f dsytrs.f dsytrs2.f
- dsytri2.f dsytri2x.f dsyswapr.f dsyconv.f
- dsysv_aa.f dsytrf_aa.f dsytrs_aa.f
+ dsytri2.f dsytri2x.f dsyswapr.f
+ dsyconv.f dsyconvf.f dsyconvf_rook.f
dsytf2_rook.f dsytrf_rook.f dsytrs_rook.f
dsytri_rook.f dsycon_rook.f dsysv_rook.f
+ dsytf2_rk.f dsytrf_rk.f dsytrs_3.f
+ dsytri_3.f dsytri_3x.f dsycon_3.f dsysv_rk.f
+ dsysv_aa.f dsytrf_aa.f dsytrs_aa.f
dtbcon.f
dtbrfs.f dtbtrs.f dtgevc.f dtgex2.f dtgexc.f dtgsen.f
dtgsja.f dtgsna.f dtgsy2.f dtgsyl.f dtpcon.f dtprfs.f dtptri.f
zhetf2.f zhetrd.f
zhetrf.f zhetri.f zhetri2.f zhetri2x.f zheswapr.f
zhetrs.f zhetrs2.f
+ zhetf2_rook.f zhetrf_rook.f zhetri_rook.f
+ zhetrs_rook.f zhecon_rook.f zhesv_rook.f
+ zhetf2_rk.f zhetrf_rk.f zhetri_3.f zhetri_3x.f
+ zhetrs_3.f zhecon_3.f zhesv_rk.f
zhesv_aa.f zhetrf_aa.f zhetrs_aa.f
- zhetf2_rook.f zhetrf_rook.f zhetri_rook.f zhetrs_rook.f zhecon_rook.f zhesv_rook.f
zhgeqz.f zhpcon.f zhpev.f zhpevd.f
zhpevx.f zhpgst.f zhpgv.f zhpgvd.f zhpgvx.f zhprfs.f zhpsv.f
zhpsvx.f
zlacgv.f zlacon.f zlacn2.f zlacp2.f zlacpy.f zlacrm.f zlacrt.f zladiv.f
zlaed0.f zlaed7.f zlaed8.f
zlaein.f zlaesy.f zlaev2.f zlags2.f zlagtm.f
- zlahef.f zlahef_rook.f zlahef_aa.f zlahqr.f
+ zlahef.f zlahef_rook.f zlahef_rk.f zlahef_aa.f zlahqr.f
zlahr2.f zlaic1.f zlals0.f zlalsa.f zlalsd.f zlangb.f zlange.f
zlangt.f zlanhb.f
zlanhe.f
zlarfg.f zlarfgp.f zlarft.f
zlarfx.f zlargv.f zlarnv.f zlarrv.f zlartg.f zlartv.f
zlarz.f zlarzb.f zlarzt.f zlascl.f zlaset.f zlasr.f
- zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f
+ zlassq.f zlaswp.f zlasyf.f zlasyf_rook.f zlasyf_rk.f
zlatbs.f zlatdf.f zlatps.f zlatrd.f zlatrs.f zlatrz.f zlauu2.f
zlauum.f zpbcon.f zpbequ.f zpbrfs.f zpbstf.f zpbsv.f
zpbsvx.f zpbtf2.f zpbtrf.f zpbtrs.f zpocon.f zpoequ.f zporfs.f
zstegr.f zstein.f zsteqr.f zsycon.f zsymv.f
zsyr.f zsyrfs.f zsysv.f zsysvx.f zsytf2.f zsytrf.f zsytri.f
zsytri2.f zsytri2x.f zsyswapr.f
- zsytrs.f zsytrs2.f zsyconv.f
+ zsytrs.f zsytrs2.f
+ zsyconv.f zsyconvf.f zsyconvf_rook.f
zsytf2_rook.f zsytrf_rook.f zsytrs_rook.f
zsytri_rook.f zsycon_rook.f zsysv_rook.f
+ zsytf2_rk.f zsytrf_rk.f zsytrs_3.f
+ zsytri_3.f zsytri_3x.f zsycon_3.f zsysv_rk.f
ztbcon.f ztbrfs.f ztbtrs.f ztgevc.f ztgex2.f
ztgexc.f ztgsen.f ztgsja.f ztgsna.f ztgsy2.f ztgsyl.f ztpcon.f
ztprfs.f ztptri.f
slarf.o slarfb.o slarfg.o slarfgp.o slarft.o slarfx.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 \
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 \
+ ssyswapr.o ssytrs.o ssytrs2.o ssyconv.o ssyconvf_rook.o \
ssytf2_rook.o ssytrf_rook.o ssytrs_rook.o \
- slasyf_aa.o ssysv_aa.o ssytrf_aa.o ssytrs_aa.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 \
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 \
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_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\
chgeqz.o chpcon.o chpev.o chpevd.o \
chpevx.o chpgst.o chpgv.o chpgvd.o chpgvx.o chprfs.o chpsv.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 clahqr.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 \
clarf.o clarfb.o clarfg.o clarft.o clarfgp.o \
clarfx.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 clatbs.o clatdf.o clatps.o clatrd.o clatrs.o clatrz.o \
+ claswp.o clasyf.o clasyf_rook.o clasyf_rk.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 \
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 \
+ 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 csytrs_3.o \
+ csytri_3.o csytri_3x.o csycon_3.o csysv_rk.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 \
dlaqtr.o dlar1v.o dlar2v.o iladlr.o iladlc.o \
dlarf.o dlarfb.o dlarfg.o dlarfgp.o dlarft.o dlarfx.o \
dlargv.o dlarrv.o dlartv.o \
- dlarz.o dlarzb.o dlarzt.o dlaswp.o dlasy2.o dlasyf.o dlasyf_rook.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 \
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 \
+ dsyswapr.o dsytrs.o dsytrs2.o \
+ dsyconv.o dsyconvf.o dsyconvf_rook.o \
dsytf2_rook.o dsytrf_rook.o dsytrs_rook.o \
- dlasyf_aa.o dsysv_aa.o dsytrf_aa.o dsytrs_aa.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 \
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 \
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_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 \
zhgeqz.o zhpcon.o zhpev.o zhpevd.o \
zhpevx.o zhpgst.o zhpgv.o zhpgvd.o zhpgvx.o zhprfs.o zhpsv.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 zlahqr.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 \
zlarfg.o zlarft.o zlarfgp.o \
zlarfx.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 \
+ zlassq.o zlaswp.o zlasyf.o zlasyf_rook.o zlasyf_rk.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 \
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 \
+ zsyswapr.o zsytrs.o zsytrs2.o \
+ zsyconv.o zsyconvf.o zsyconvf_rook.o \
zsytf2_rook.o zsytrf_rook.o zsytrs_rook.o \
zsytri_rook.o zsycon_rook.o zsysv_rook.o \
+ zsytf2_rk.o zsytrf_rk.o zsytrs_3.o \
+ zsytri_3.o zsytri_3x.o zsycon_3.o zsysv_rk.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 \
dla_wwaddw.o: dla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@
cla_wwaddw.o: cla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@
zla_wwaddw.o: zla_wwaddw.f ; $(FORTRAN) $(NOOPT) -c $< -o $@
-
--- /dev/null
+*> \brief \b CHECON_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHECON_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/checon_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/checon_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/checon_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* COMPLEX A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHECON_3 estimates the reciprocal of the condition number (in the
+*> 1-norm) of a complex Hermitian matrix A using the factorization
+*> computed by CHETRF_RK or CHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> This routine uses BLAS3 solver CHETRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by CHETRF_RK and CHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_RK or CHETRF_BK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is REAL
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is REAL
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER 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.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+ $ WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHETRS_3, CLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHECON_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
+*
+ CALL CHETRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of CHECON_3
+*
+ END
--- /dev/null
+*> \brief <b> CHESV_RK computes the solution to system of linear equations A * X = B for SY matrices</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHESV_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chesv_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chesv_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chesv_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHESV_RK computes the solution to a complex system of linear
+*> equations A * X = B, where A is an N-by-N Hermitian matrix
+*> and X and B are N-by-NRHS matrices.
+*>
+*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
+*> to factor A as
+*> A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or
+*> A = P*L*D*(L**H)*(P**T), if UPLO = 'L',
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> CHETRF_RK is called to compute the factorization of a complex
+*> Hermitian matrix. The factored form of A is then used to solve
+*> the system of equations A * X = B by calling BLAS3 routine CHETRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order 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,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, if INFO = 0, diagonal of the block diagonal
+*> matrix D and factors U or L as computed by CHETRF_RK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> For more info see the description of CHETRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the output computed by the factorization
+*> routine CHETRF_RK, i.e. the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*>
+*> For more info see the description of CHETRF_RK routine.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by CHETRF_RK.
+*>
+*> For more info see the description of CHETRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension ( MAX(1,LWORK) ).
+*> Work array used in the factorization stage.
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= 1. For best performance
+*> of factorization stage LWORK >= max(1,N*NB), where NB is
+*> the optimal blocksize for CHETRF_RK.
+*>
+*> If LWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of the WORK
+*> array for factorization stage, 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CHETRF_RK, CHETRS_3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHESV_RK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**T or A = L*D*L**T.
+*
+ CALL CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B with BLAS3 solver, overwriting B with X.
+*
+ CALL CHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of CHESV_RK
+*
+ END
--- /dev/null
+*> \brief \b CHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETF2_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetf2_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetf2_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetf2_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E ( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHETF2_RK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put further details
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept.,
+*> Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * )
+* ..
+*
+* ======================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE, UPPER
+ INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
+ $ P
+ REAL ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, STEMP,
+ $ ROWMAX, TT, SFMIN
+ COMPLEX D12, D21, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH, SLAPY2
+ EXTERNAL LSAME, ICAMAX, SLAMCH, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CSSCAL, CHER, CSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AIMAG, CMPLX, CONJG, MAX, REAL, SQRT
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETF2_RK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**H using the upper triangle of A
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 34
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( A( K, K ) )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the leading submatrix A(1:k,1:k)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.GT.1 )
+ $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 14 J = P + 1, K - 1
+ T = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( P, J ) )
+ A( P, J ) = T
+ 14 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = CONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( K, K ) )
+ A( K, K ) = REAL( A( P, P ) )
+ A( P, P ) = R1
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA )
+*
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the leading submatrix A(1:k,1:k)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 15 J = KP + 1, KK - 1
+ T = CONJG( A( J, KK ) )
+ A( J, KK ) = CONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 15 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = CONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( KK, KK ) )
+ A( KK, KK ) = REAL( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+* (5) Swap row elements
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+*
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K-1, K-1 ) = REAL( A( K-1, K-1 ) )
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / REAL( A( K, K ) )
+ CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL CSSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = REAL( A( K, K ) )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+* D = |A12|
+ D = SLAPY2( REAL( A( K-1, K ) ),
+ $ AIMAG( A( K-1, K ) ) )
+ D11 = A( K, K ) / D
+ D22 = A( K-1, K-1 ) / D
+ D12 = A( K-1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WKM1 = TT*( D11*A( J, K-1 )-CONJG( D12 )*
+ $ A( J, K ) )
+ WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) )
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2)
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*CONJG( WK ) -
+ $ ( A( I, K-1 ) / D )*CONJG( WKM1 )
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K-1 ) = WKM1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO )
+*
+ 30 CONTINUE
+*
+ END IF
+*
+* Copy superdiagonal elements of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ E( K ) = A( K-1, K )
+ E( K-1 ) = CZERO
+ A( K-1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 34 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**H using the lower triangle of A
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 64
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( A( K, K ) )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 42
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the trailing submatrix A(k:n,k:n)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.LT.N )
+ $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 44 J = K + 1, P - 1
+ T = CONJG( A( J, K ) )
+ A( J, K ) = CONJG( A( P, J ) )
+ A( P, J ) = T
+ 44 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = CONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( K, K ) )
+ A( K, K ) = REAL( A( P, P ) )
+ A( P, P ) = R1
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+*
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the trailing submatrix A(k:n,k:n)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 45 J = KK + 1, KP - 1
+ T = CONJG( A( J, KK ) )
+ A( J, KK ) = CONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 45 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = CONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = REAL( A( KK, KK ) )
+ A( KK, KK ) = REAL( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+* (5) Swap row elements
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+*
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = REAL( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K+1, K+1 ) = REAL( A( K+1, K+1 ) )
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of A now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+* Handle division by a small number
+*
+ IF( ABS( REAL( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / REAL( A( K, K ) )
+ CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL CSSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = REAL( A( K, K ) )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+* D = |A21|
+ D = SLAPY2( REAL( A( K+1, K ) ),
+ $ AIMAG( A( K+1, K ) ) )
+ D11 = REAL( A( K+1, K+1 ) ) / D
+ D22 = REAL( A( K, K ) ) / D
+ D21 = A( K+1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) )
+ WKP1 = TT*( D22*A( J, K+1 )-CONJG( D21 )*
+ $ A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*CONJG( WK ) -
+ $ ( A( I, K+1 ) / D )*CONJG( WKP1 )
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K+1 ) = WKP1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = CMPLX( REAL( A( J, J ) ), ZERO )
+*
+ 60 CONTINUE
+*
+ END IF
+*
+* Copy subdiagonal elements of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ E( K ) = A( K+1, K )
+ E( K+1 ) = CZERO
+ A( K+1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ 64 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of CHETF2_RK
+*
+ END
--- /dev/null
+*> \brief \b CHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHETRF_RK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX 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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned
+*> by ILAENV.
+*>
+*> 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put correct description
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
+ $ NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLAHEF_RK, CHETF2_RK, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'CHETRF_RK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRF_RK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'CHETRF_RK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by CLAHEF_RK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 15
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL CLAHEF_RK( UPLO, K, NB, KB, A, LDA, E,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL CHETF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k-kb+1:k and apply row permutations to the
+* last k+1 colunms k+1:N after that block
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.LT.N ) THEN
+ DO I = K, ( K - KB + 1 ), -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-K, A( I, K+1 ), LDA,
+ $ A( IP, K+1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+* This label is the exit from main loop over K decreasing
+* from N to 1 in steps of KB
+*
+ 15 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by CLAHEF_RK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 35
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL CLAHEF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+
+
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL CHETF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), IINFO )
+ KB = N - K + 1
+*
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO I = K, K + KB - 1
+ IF( IPIV( I ).GT.0 ) THEN
+ IPIV( I ) = IPIV( I ) + K - 1
+ ELSE
+ IPIV( I ) = IPIV( I ) - K + 1
+ END IF
+ END DO
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k:k+kb-1 and apply row permutations to the
+* first k-1 colunms 1:k-1 before that block
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.GT.1 ) THEN
+ DO I = K, ( K + KB - 1 ), 1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( K-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+* This label is the exit from main loop over K increasing
+* from 1 to N in steps of KB
+*
+ 35 CONTINUE
+*
+* End Lower
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of CHETRF_RK
+*
+ END
--- /dev/null
+*> \brief \b CHETRI_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRI_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetri_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetri_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetri_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHETRI_3 computes the inverse of a complex Hermitian indefinite
+*> matrix A using the factorization computed by CHETRF_RK or CHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> CHETRI_3 sets the leading dimension of the workspace before calling
+*> CHETRI_3X that actually computes the inverse. This is the blocked
+*> version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by CHETRF_RK and CHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the Hermitian inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_RK or CHETRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (N+NB+1)*(NB+3).
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= (N+NB+1)*(NB+3).
+*>
+*> If LDWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of 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
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHETRI_3X
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* Determine the block size
+*
+ NB = MAX( 1, ILAENV( 1, 'CHETRI_3', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = ( N+NB+1 ) * ( NB+3 )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRI_3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ WORK( 1 ) = LWKOPT
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ CALL CHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of CHETRI_3
+*
+ END
--- /dev/null
+*> \brief \b CHETRI_3X
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRI_3X + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetri_3x.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetri_3x.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetri_3x.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHETRI_3X computes the inverse of a complex Hermitian indefinite
+*> matrix A using the factorization computed by CHETRF_RK or CHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by CHETRF_RK and CHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the Hermitian inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_RK or CHETRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (N+NB+1,NB+3).
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11
+ REAL AK, AKP1, T
+ COMPLEX AKKP1, D, U01_I_J, U01_IP1_J, U11_I_J,
+ $ U11_IP1_J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMM, CHESWAPR, CTRTRI, CTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CONJG, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+*
+* Quick return if possible
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRI_3X', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Workspace got Non-diag elements of D
+*
+ DO K = 1, N
+ WORK( K, 1 ) = E( K )
+ END DO
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+ INFO = 0
+*
+* Splitting Workspace
+* U01 is a block ( N, NB+1 )
+* The first element of U01 is in WORK( 1, 1 )
+* U11 is a block ( NB+1, NB+1 )
+* The first element of U11 is in WORK( N+1, 1 )
+*
+ U11 = N
+*
+* INVD is a block ( N, 2 )
+* The first element of INVD is in WORK( 1, INVD )
+*
+ INVD = NB + 2
+
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* invA = P * inv(U**H) * inv(D) * inv(U) * P**T.
+*
+ CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(U)
+*
+ K = 1
+ DO WHILE( K.LE.N )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / REAL( A( K, K ) )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = ABS( WORK( K+1, 1 ) )
+ AK = REAL( A( K, K ) ) / T
+ AKP1 = REAL( A( K+1, K+1 ) ) / T
+ AKKP1 = WORK( K+1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K, INVD ) = AKP1 / D
+ WORK( K+1, INVD+1 ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K+1, INVD ) = CONJG( WORK( K, INVD+1 ) )
+ K = K + 1
+ END IF
+ K = K + 1
+ END DO
+*
+* inv(U**H) = (inv(U))**H
+*
+* inv(U**H) * inv(D) * inv(U)
+*
+ CUT = N
+ DO WHILE( CUT.GT.0 )
+ NNB = NB
+ IF( CUT.LE.NNB ) THEN
+ NNB = CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT+1-NNB, CUT
+ IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+
+ CUT = CUT - NNB
+*
+* U01 Block
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ WORK( I, J ) = A( I, CUT+J )
+ END DO
+ END DO
+*
+* U11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I ) = CONE
+ DO J = 1, I-1
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD * U01
+*
+ I = 1
+ DO WHILE( I.LE.CUT )
+ IF( IPIV( I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( I, INVD ) * WORK( I, J )
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK( I, J )
+ U01_IP1_J = WORK( I+1, J )
+ WORK( I, J ) = WORK( I, INVD ) * U01_I_J
+ $ + WORK( I, INVD+1 ) * U01_IP1_J
+ WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J
+ $ + WORK( I+1, INVD+1 ) * U01_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* invD1 * U11
+*
+ I = 1
+ DO WHILE ( I.LE.NNB )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = I, NNB
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ END DO
+ ELSE
+ DO J = I, NNB
+ U11_I_J = WORK(U11+I,J)
+ U11_IP1_J = WORK(U11+I+1,J)
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J)
+ WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J
+ $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* U11**H * invD1 * U11 -> U11
+*
+ CALL CTRMM( 'L', 'U', 'C', 'U', NNB, NNB,
+ $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+* U01**H * invD * U01 -> A( CUT+I, CUT+J )
+*
+ CALL CGEMM( 'C', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ),
+ $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1),
+ $ N+NB+1 )
+
+*
+* U11 = U11**H * invD1 * U11 + U01**H * invD * U01
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J)
+ END DO
+ END DO
+*
+* U01 = U00**H * invD0 * U01
+*
+ CALL CTRMM( 'L', UPLO, 'C', 'U', CUT, NNB,
+ $ CONE, A, LDA, WORK, N+NB+1 )
+
+*
+* Update U01
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ A( I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+* Next Block
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(U**H) * inv(D) * inv(U) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Upper case.
+*
+* ( We can use a loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = 1, N
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL CHESWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL CHESWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* inv A = P * inv(L**H) * inv(D) * inv(L) * P**T.
+*
+ CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(L)
+*
+ K = N
+ DO WHILE ( K .GE. 1 )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / REAL( A( K, K ) )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = ABS( WORK( K-1, 1 ) )
+ AK = REAL( A( K-1, K-1 ) ) / T
+ AKP1 = REAL( A( K, K ) ) / T
+ AKKP1 = WORK( K-1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K-1, INVD ) = AKP1 / D
+ WORK( K, INVD ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K-1, INVD+1 ) = CONJG( WORK( K, INVD+1 ) )
+ K = K - 1
+ END IF
+ K = K - 1
+ END DO
+*
+* inv(L**H) = (inv(L))**H
+*
+* inv(L**H) * inv(D) * inv(L)
+*
+ CUT = 0
+ DO WHILE( CUT.LT.N )
+ NNB = NB
+ IF( (CUT + NNB).GT.N ) THEN
+ NNB = N - CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT + 1, CUT+NNB
+ IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+*
+* L21 Block
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ WORK( I, J ) = A( CUT+NNB+I, CUT+J )
+ END DO
+ END DO
+*
+* L11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I) = CONE
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = 1, I-1
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD*L21
+*
+ I = N-CUT-NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+NNB+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J)
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK(I,J)
+ U01_IP1_J = WORK(I-1,J)
+ WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+
+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J
+ WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+
+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* invD1*L11
+*
+ I = NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J)
+ END DO
+
+ ELSE
+ DO J = 1, NNB
+ U11_I_J = WORK( U11+I, J )
+ U11_IP1_J = WORK( U11+I-1, J )
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * U11_IP1_J
+ WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J
+ $ + WORK(CUT+I-1,INVD) * U11_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* L11**H * invD1 * L11 -> L11
+*
+ CALL CTRMM( 'L', UPLO, 'C', 'U', NNB, NNB, CONE,
+ $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+ IF( (CUT+NNB).LT.N ) THEN
+*
+* L21**H * invD2*L21 -> A( CUT+I, CUT+J )
+*
+ CALL CGEMM( 'C', 'N', NNB, NNB, N-NNB-CUT, CONE,
+ $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1,
+ $ CZERO, WORK( U11+1, 1 ), N+NB+1 )
+
+*
+* L11 = L11**H * invD1 * L11 + U01**H * invD * U01
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J)
+ END DO
+ END DO
+*
+* L01 = L22**H * invD2 * L21
+*
+ CALL CTRMM( 'L', UPLO, 'C', 'U', N-NNB-CUT, NNB, CONE,
+ $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK,
+ $ N+NB+1 )
+*
+* Update L21
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ A( CUT+NNB+I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+ ELSE
+*
+* L11 = L11**H * invD1 * L11
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+ END IF
+*
+* Next Block
+*
+ CUT = CUT + NNB
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(L**H) * inv(D) * inv(L) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Lower case.
+*
+* ( We can use a loop over IPIV with increment -1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = N, 1, -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL CHESWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL CHESWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of CHETRI_3X
+*
+ END
--- /dev/null
+*> \brief \b CHETRS_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CHETRS_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrs_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrs_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrs_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CHETRS_3 solves a system of linear equations A * X = B with a complex
+*> Hermitian matrix A using the factorization computed
+*> by CHETRF_RK or CHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This algorithm is using Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order 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] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by CHETRF_RK and CHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CHETRF_RK or CHETRF_BK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,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.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = ( 1.0E+0,0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J, K, KP
+ REAL S
+ COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CSSCAL, CSWAP, CTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CONJG, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CHETRS_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* Solve A*X = B, where A = U*D*U**H.
+*
+* P**T * B
+*
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
+*
+ CALL CTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (U \P**T * B) ]
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+ S = REAL( ONE ) / REAL( A( I, I ) )
+ CALL CSSCAL( NRHS, S, B( I, 1 ), LDB )
+ ELSE IF ( I.GT.1 ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I-1, I-1 ) / AKM1K
+ AK = A( I, I ) / CONJG( AKM1K )
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I-1, J ) / AKM1K
+ BK = B( I, J ) / CONJG( AKM1K )
+ B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ]
+*
+ CALL CTRSM( 'L', 'U', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* Solve A*X = B, where A = L*D*L**H.
+*
+* P**T * B
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
+*
+ CALL CTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (L \P**T * B) ]
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+ S = REAL( ONE ) / REAL( A( I, I ) )
+ CALL CSSCAL( NRHS, S, B( I, 1 ), LDB )
+ ELSE IF( I.LT.N ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I, I ) / CONJG( AKM1K )
+ AK = A( I+1, I+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I, J ) / CONJG( AKM1K )
+ BK = B( I+1, J ) / AKM1K
+ B( I, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ]
+*
+ CALL CTRSM('L', 'L', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* END Lower
+*
+ END IF
+*
+ RETURN
+*
+* End of CHETRS_3
+*
+ END
+++ /dev/null
-*> \brief \b CHETRS_AASEN
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-*> \htmlonly
-*> Download CHETRS_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [TXT]</a>
-*> \endhtmlonly
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
-* WORK, LWORK, INFO )
-*
-* .. Scalar Arguments ..
-* CHARACTER UPLO
-* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
-* ..
-* .. Array Arguments ..
-* INTEGER IPIV( * )
-* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> CHETRS_AASEN solves a system of linear equations A*X = B with a real
-*> hermitian matrix A using the factorization A = U*T*U**T or
-*> A = L*T*L**T computed by CHETRF_AASEN.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] UPLO
-*> \verbatim
-*> UPLO is CHARACTER*1
-*> Specifies whether the details of the factorization are stored
-*> as an upper or lower triangular matrix.
-*> = 'U': Upper triangular, form is A = U*T*U**T;
-*> = 'L': Lower triangular, form is A = L*T*L**T.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The order 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,out] A
-*> \verbatim
-*> A is COMPLEX array, dimension (LDA,N)
-*> Details of factors computed by CHETRF_AASEN.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array A. LDA >= max(1,N).
-*> \endverbatim
-*>
-*> \param[in] IPIV
-*> \verbatim
-*> IPIV is INTEGER array, dimension (N)
-*> Details of the interchanges as computed by CHETRF_AASEN.
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is COMPLEX array, dimension (LDB,NRHS)
-*> On entry, the right hand side matrix B.
-*> On exit, the solution matrix X.
-*> \endverbatim
-*>
-*> \param[in] LDB
-*> \verbatim
-*> LDB is INTEGER
-*> The leading dimension of the array B. LDB >= max(1,N).
-*> \endverbatim
-*>
-*> \param[in] WORK
-*> \verbatim
-*> WORK is DOUBLE array, dimension (MAX(1,LWORK))
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER, LWORK >= 3*N-2.
-*>
-*> \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.
-*
-*> \date November 2016
-*
-*> \ingroup complexSYcomputational
-*
-* @generated from zhetrs_aasen.f, fortran z -> c, Fri Sep 23 00:09:52 2016
-*
-* =====================================================================
- SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
- $ WORK, LWORK, INFO )
-*
-* -- LAPACK computational routine (version 3.4.0) --
-* -- LAPACK is a software package provided by Univ. of Tennessee, --
-* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2016
-*
- IMPLICIT NONE
-*
-* .. Scalar Arguments ..
- CHARACTER UPLO
- INTEGER N, NRHS, LDA, LDB, LWORK, INFO
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
-* ..
-*
-* =====================================================================
-*
- COMPLEX ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER K, KP
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CGTSV, CSWAP, CTRSM, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-* .. Executable Statements ..
-*
- INFO = 0
- UPPER = LSAME( UPLO, 'U' )
- IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
- INFO = -1
- ELSE IF( N.LT.0 ) THEN
- INFO = -2
- ELSE IF( NRHS.LT.0 ) THEN
- INFO = -3
- ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
- INFO = -5
- ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
- INFO = -8
- ELSE IF( LWORK.LT.(3*N-2) ) THEN
- INFO = -10
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'CHETRS_AASEN', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( N.EQ.0 .OR. NRHS.EQ.0 )
- $ RETURN
-*
- IF( UPPER ) THEN
-*
-* Solve A*X = B, where A = U*T*U**T.
-*
-* P**T * B
-*
- K = 1
- DO WHILE ( K.LE.N )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K + 1
- END DO
-*
-* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
-*
- CALL CTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
- $ B( 2, 1 ), LDB)
-*
-* Compute T \ B -> B [ T \ (U \P**T * B) ]
-*
- CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
- IF( N.GT.1 ) THEN
- CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1)
- CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1)
- CALL CLACGV( N-1, WORK( 1 ), 1 )
- END IF
- CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
- $ INFO)
-*
-* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ]
-*
- CALL CTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
- $ B(2, 1), LDB)
-*
-* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ]
-*
- K = N
- DO WHILE ( K.GE.1 )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K - 1
- END DO
-*
- ELSE
-*
-* Solve A*X = B, where A = L*T*L**T.
-*
-* Pivot, P**T * B
-*
- K = 1
- DO WHILE ( K.LE.N )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K + 1
- END DO
-*
-* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
-*
- CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA,
- $ B(2, 1), LDB)
-*
-* Compute T \ B -> B [ T \ (L \P**T * B) ]
-*
- CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
- IF( N.GT.1 ) THEN
- CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1)
- CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1)
- CALL CLACGV( N-1, WORK( 2*N ), 1 )
- END IF
- CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
- $ INFO)
-*
-* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
- CALL CTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
- $ B( 2, 1 ), LDB)
-*
-* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ]
-*
- K = N
- DO WHILE ( K.GE.1 )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K - 1
- END DO
-*
- END IF
-*
- RETURN
-*
-* End of CHETRS_AASEN
-*
- END
+++ /dev/null
-*> \brief \b CHETRS_AASEN
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-*> \htmlonly
-*> Download CHETRS_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/chetrs_aasen.f">
-*> [TXT]</a>
-*> \endhtmlonly
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
-* WORK, LWORK, INFO )
-*
-* .. Scalar Arguments ..
-* CHARACTER UPLO
-* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
-* ..
-* .. Array Arguments ..
-* INTEGER IPIV( * )
-* COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> CHETRS_AASEN solves a system of linear equations A*X = B with a real
-*> hermitian matrix A using the factorization A = U*T*U**T or
-*> A = L*T*L**T computed by CHETRF_AASEN.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] UPLO
-*> \verbatim
-*> UPLO is CHARACTER*1
-*> Specifies whether the details of the factorization are stored
-*> as an upper or lower triangular matrix.
-*> = 'U': Upper triangular, form is A = U*T*U**T;
-*> = 'L': Lower triangular, form is A = L*T*L**T.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The order 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,out] A
-*> \verbatim
-*> A is COMPLEX array, dimension (LDA,N)
-*> Details of factors computed by CHETRF_AASEN.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array A. LDA >= max(1,N).
-*> \endverbatim
-*>
-*> \param[in] IPIV
-*> \verbatim
-*> IPIV is INTEGER array, dimension (N)
-*> Details of the interchanges as computed by CHETRF_AASEN.
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is COMPLEX array, dimension (LDB,NRHS)
-*> On entry, the right hand side matrix B.
-*> On exit, the solution matrix X.
-*> \endverbatim
-*>
-*> \param[in] LDB
-*> \verbatim
-*> LDB is INTEGER
-*> The leading dimension of the array B. LDB >= max(1,N).
-*> \endverbatim
-*>
-*> \param[in] WORK
-*> \verbatim
-*> WORK is DOUBLE array, dimension (MAX(1,LWORK))
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER, LWORK >= 3*N-2.
-*>
-*> \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.
-*
-*> \date November 2016
-*
-*> \ingroup complexSYcomputational
-*
-* @generated from zhetrs_aasen.f, fortran z -> c, Fri Sep 23 00:09:52 2016
-*
-* =====================================================================
- SUBROUTINE CHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
- $ WORK, LWORK, INFO )
-*
-* -- LAPACK computational routine (version 3.4.0) --
-* -- LAPACK is a software package provided by Univ. of Tennessee, --
-* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2016
-*
- IMPLICIT NONE
-*
-* .. Scalar Arguments ..
- CHARACTER UPLO
- INTEGER N, NRHS, LDA, LDB, LWORK, INFO
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- COMPLEX A( LDA, * ), B( LDB, * ), WORK( * )
-* ..
-*
-* =====================================================================
-*
- COMPLEX ONE
- PARAMETER ( ONE = 1.0E+0 )
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER K, KP
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL CGTSV, CSWAP, CTRSM, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-* .. Executable Statements ..
-*
- INFO = 0
- UPPER = LSAME( UPLO, 'U' )
- IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
- INFO = -1
- ELSE IF( N.LT.0 ) THEN
- INFO = -2
- ELSE IF( NRHS.LT.0 ) THEN
- INFO = -3
- ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
- INFO = -5
- ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
- INFO = -8
- ELSE IF( LWORK.LT.(3*N-2) ) THEN
- INFO = -10
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'CHETRS_AASEN', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( N.EQ.0 .OR. NRHS.EQ.0 )
- $ RETURN
-*
- IF( UPPER ) THEN
-*
-* Solve A*X = B, where A = U*T*U**T.
-*
-* P**T * B
-*
- K = 1
- DO WHILE ( K.LE.N )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K + 1
- END DO
-*
-* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
-*
- CALL CTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
- $ B( 2, 1 ), LDB)
-*
-* Compute T \ B -> B [ T \ (U \P**T * B) ]
-*
- CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
- IF( N.GT.1 ) THEN
- CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1)
- CALL CLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1)
- CALL CLACGV( N-1, WORK( 1 ), 1 )
- END IF
- CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
- $ INFO)
-*
-* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ]
-*
- CALL CTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
- $ B(2, 1), LDB)
-*
-* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ]
-*
- K = N
- DO WHILE ( K.GE.1 )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K - 1
- END DO
-*
- ELSE
-*
-* Solve A*X = B, where A = L*T*L**T.
-*
-* Pivot, P**T * B
-*
- K = 1
- DO WHILE ( K.LE.N )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K + 1
- END DO
-*
-* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
-*
- CALL CTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1), LDA,
- $ B(2, 1), LDB)
-*
-* Compute T \ B -> B [ T \ (L \P**T * B) ]
-*
- CALL CLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
- IF( N.GT.1 ) THEN
- CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1)
- CALL CLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1)
- CALL CLACGV( N-1, WORK( 2*N ), 1 )
- END IF
- CALL CGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
- $ INFO)
-*
-* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
- CALL CTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
- $ B( 2, 1 ), LDB)
-*
-* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ]
-*
- K = N
- DO WHILE ( K.GE.1 )
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- K = K - 1
- END DO
-*
- END IF
-*
- RETURN
-*
-* End of CHETRS_AASEN
-*
- END
--- /dev/null
+*> \brief \b CLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CLAHEF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clahef_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clahef_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clahef_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CLAHEF_RK computes a partial factorization of a complex Hermitian
+*> matrix A using the bounded Bunch-Kaufman (rook) diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L',
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> CLAHEF_RK is an auxiliary routine called by CHETRF_RK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,N-KB+1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,N-KB+1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,N-KB+1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,1:KB).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexHEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), W( LDW, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, K, KK, KKW,
+ $ KP, KSTEP, KW, P
+ REAL ABSAKK, ALPHA, COLMAX, STEMP, R1, ROWMAX, T,
+ $ SFMIN
+ COMPLEX D11, D21, D22, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ICAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CCOPY, CSSCAL, CGEMM, CGEMV, CLACGV, CSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, CONJG, AIMAG, MAX, MIN, REAL, SQRT
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11 (note that conjg(W) is actually stored)
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ IF( K.GT.1 )
+ $ CALL CCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
+ W( K, KW ) = REAL( A( K, K ) )
+ IF( K.LT.N ) THEN
+ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+ $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+ W( K, KW ) = REAL( W( K, KW ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( W( K, KW ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( W( K, KW ) )
+ IF( K.GT.1 )
+ $ CALL CCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+* Lop until pivot found
+*
+ DONE = .FALSE.
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ IF( IMAX.GT.1 )
+ $ CALL CCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ),
+ $ 1 )
+ W( IMAX, KW-1 ) = REAL( A( IMAX, IMAX ) )
+*
+ CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+ CALL CLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N ) THEN
+ CALL CGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+ W( IMAX, KW-1 ) = REAL( W( IMAX, KW-1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ STEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( W( IMAX,KW-1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+* Interchange rows and columns P and K.
+* Updated column P is already stored in column KW of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K-1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = REAL( A( K, K ) )
+ CALL CCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ CALL CLACGV( K-1-P, A( P, P+1 ), LDA )
+ IF( P.GT.1 )
+ $ CALL CCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in the last K+1 to N columns of A
+* (columns K and K-1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ),
+ $ LDA )
+ CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ),
+ $ LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = REAL( A( KK, KK ) )
+ CALL CCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL CLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
+ IF( KP.GT.1 )
+ $ CALL CCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+ CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column kw of W now holds
+*
+* W(kw) = U(k)*D(k),
+*
+* where U(k) is the k-th column of U
+*
+* (1) Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = REAL( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL CSSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+ DO 14 II = 1, K-1
+ A( II, K ) = A( II, K ) / T
+ 14 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(kw)
+*
+ CALL CLACGV( K-1, W( 1, KW ), 1 )
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
+*
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored)
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
+*
+ IF( K.GT.2 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K-1, KW )
+ D11 = W( K, KW ) / CONJG( D21 )
+ D22 = W( K-1, KW-1 ) / D21
+ T = ONE / ( REAL( D11*D22 )-ONE )
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D21 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ CONJG( D21 ) )
+ 20 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy superdiagonal element of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = CZERO
+ A( K, K ) = W( K, KW )
+ E( K ) = W( K-1, KW )
+ E( K-1 ) = CZERO
+*
+* (2) Conjugate columns W(kw) and W(kw-1)
+*
+ CALL CLACGV( K-1, W( 1, KW ), 1 )
+ CALL CLACGV( K-2, W( 1, KW-1 ), 1 )
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+ $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22 (note that conjg(W) is actually stored)
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update column K of W
+*
+ W( K, K ) = REAL( A( K, K ) )
+ IF( K.LT.N )
+ $ CALL CCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+ W( K, K ) = REAL( W( K, K ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( REAL( W( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = REAL( W( K, K ) )
+ IF( K.LT.N )
+ $ CALL CCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column k+1 of W and update it
+*
+ CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL CLACGV( IMAX-K, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = REAL( A( IMAX, IMAX ) )
+*
+ IF( IMAX.LT.N )
+ $ CALL CCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
+ $ W( IMAX+1, K+1 ), 1 )
+*
+ IF( K.GT.1 ) THEN
+ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = REAL( W( IMAX, K+1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ STEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( REAL( W( IMAX,K+1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+*
+* End pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 72
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* Interchange rows and columns P and K (only for 2-by-2 pivot).
+* Updated column P is already stored in column K of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column KK-1 to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K+1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = REAL( A( K, K ) )
+ CALL CCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ CALL CLACGV( P-K-1, A( P, K+1 ), LDA )
+ IF( P.LT.N )
+ $ CALL CCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+*
+* Interchange rows K and P in first K-1 columns of A
+* (columns K and K+1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = REAL( A( KK, KK ) )
+ CALL CCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ CALL CLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
+ IF( KP.LT.N )
+ $ CALL CCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+*
+* Interchange rows KK and KP in first K-1 columns of A
+* (column K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+* (1) Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = REAL( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL CSSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / T
+ 74 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(k)
+*
+ CALL CLACGV( N-K, W( K+1, K ), 1 )
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored.
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / CONJG( D21 )
+ T = ONE / ( REAL( D11*D22 )-ONE )
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ CONJG( D21 ) )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy subdiagonal element of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = CZERO
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ E( K ) = W( K+1, K )
+ E( K+1 ) = CZERO
+*
+* (2) Conjugate columns W(k) and W(k+1)
+*
+ CALL CLACGV( N-K, W( K+1, K ), 1 )
+ CALL CLACGV( N-K-1, W( K+2, K+1 ), 1 )
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ A( JJ, JJ ) = REAL( A( JJ, JJ ) )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of CLAHEF_RK
+*
+ END
--- /dev/null
+*> \brief \b CLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CLASYF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clasyf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clasyf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clasyf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CLASYF_RK computes a partial factorization of a complex symmetric
+*> matrix A using the bounded Bunch-Kaufman (rook) diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L',
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> CLASYF_RK is an auxiliary routine called by CSYTRF_RK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,N-KB+1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,N-KB+1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,N-KB+1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,1:KB).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW,
+ $ KP, KSTEP, P, II
+ REAL ABSAKK, ALPHA, COLMAX, ROWMAX, SFMIN, STEMP
+ COMPLEX D11, D12, D21, D22, R1, T, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ICAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CCOPY, CGEMM, CGEMV, CSCAL, CSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AIMAG, MAX, MIN, REAL, SQRT
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL CCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL CGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL CCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL CCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL CGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ STEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL CCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL CCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL CSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL CSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL CCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL CCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL CSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL CSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL CCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL CSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = CONE / ( D11*D22-CONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy superdiagonal element of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = CZERO
+ A( K, K ) = W( K, KW )
+ E( K ) = W( K-1, KW )
+ E( K-1 ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL CGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL CGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ),
+ $ LDW, CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL CCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL CCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL CCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL CGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ STEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL CCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL CCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL CCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL CSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL CSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL CCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL CCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL CSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL CSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL CCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL CSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy subdiagonal element of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = CZERO
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ E( K ) = W( K+1, K )
+ E( K+1 ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL CGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL CGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+*
+ RETURN
+*
+* End of CLASYF_RK
+*
+ END
--- /dev/null
+*> \brief \b CSYCON_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYCON_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csycon_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csycon_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csycon_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* COMPLEX A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYCON_3 estimates the reciprocal of the condition number (in the
+*> 1-norm) of a complex symmetric matrix A using the factorization
+*> computed by CSYTRF_RK or CSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> This routine uses BLAS3 solver CSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by CSYTRF_RK and CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_RK or CSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is REAL
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is REAL
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER 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.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+ $ WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLACN2, CSYTRS_3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYCON_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL CLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL CSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of CSYCON_3
+*
+ END
--- /dev/null
+*> \brief \b CSYCONVF
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYCONVF + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csyconvf.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csyconvf.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csyconvf.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> CSYCONVF converts the factorization output format used in
+*> CSYTRF provided on entry in parameter A into the factorization
+*> output format used in CSYTRF_RK (or CSYTRF_BK) that is stored
+*> on exit in parameters A and E. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in CSYTRF into
+*> the format used in CSYTRF_RK (or CSYTRF_BK).
+*>
+*> If parameter WAY = 'R':
+*> CSYCONVF performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in CSYTRF_RK
+*> (or CSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in CSYTRF that is stored
+*> on exit in parameter A. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in CSYTRF_RK
+*> (or CSYTRF_BK) into the format used in CSYTRF.
+*>
+*> CSYCONVF can also convert in Hermitian matrix case, i.e. between
+*> formats used in CHETRF and CHETRF_RK (or CHETRF_BK).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> CSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> CSYTRF_RK or CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> CSYTRF_RK or CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> CSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in,out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in CSYTRF.
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in CSYTRF_RK
+*> ( or CSYTRF_BK).
+*>
+*> 1) If WAY ='R':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in CSYTRF_RK
+*> ( or CSYTRF_BK).
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in CSYTRF.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE CSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ZERO
+ PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL CSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYCONVF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL CSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL CSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i-1 and IPIV(i-1),
+* so this should be recorded in two consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I-1 )
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where k increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL CSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL CSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i+1 and IPIV(i+1),
+* so this should be recorded in consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I+1 )
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of CSYCONVF
+*
+ END
--- /dev/null
+*> \brief \b CSYCONVF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYCONVF_ROOK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csyconvf_rook.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csyconvf_rook.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csyconvf_rook.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> CSYCONVF_ROOK converts the factorization output format used in
+*> CSYTRF_ROOK provided on entry in parameter A into the factorization
+*> output format used in CSYTRF_RK (or CSYTRF_BK) that is stored
+*> on exit in parameters A and E. IPIV format for CSYTRF_ROOK and
+*> CSYTRF_RK (or CSYTRF_BK) is the same and is not converted.
+*>
+*> If parameter WAY = 'R':
+*> CSYCONVF_ROOK performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in CSYTRF_RK
+*> (or CSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in CSYTRF_ROOK that is stored
+*> on exit in parameter A. IPIV format for CSYTRF_ROOK and
+*> CSYTRF_RK (or CSYTRF_BK) is the same and is not converted.
+*>
+*> CSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between
+*> formats used in CHETRF_ROOK and CHETRF_RK (or CHETRF_BK).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> CSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> CSYTRF_RK or CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> CSYTRF_RK or CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> CSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> On entry, details of the interchanges and the block
+*> structure of D as determined:
+*> 1) by CSYTRF_ROOK, if WAY ='C';
+*> 2) by CSYTRF_RK (or CSYTRF_BK), if WAY ='R'.
+*> The IPIV format is the same for all these routines.
+*>
+*> On exit, is not changed.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE CSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ZERO
+ PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL CSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP, IP2
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYCONVF_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i-1 and IPIV(i-1)
+* in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ IF( IP2.NE.(I-1) ) THEN
+ CALL CSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP2, I+1 ), LDA )
+ END IF
+ END IF
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i-1) and i and IPIV(i)
+* in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP2.NE.(I-1) ) THEN
+ CALL CSWAP( N-I, A( IP2, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i+1 and IPIV(i+1)
+* in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ IF( IP2.NE.(I+1) ) THEN
+ CALL CSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP2, 1 ), LDA )
+ END IF
+ END IF
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i+1) and i and IPIV(i)
+* in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP2.NE.(I+1) ) THEN
+ CALL CSWAP( I-1, A( IP2, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of CSYCONVF_ROOK
+*
+ END
--- /dev/null
+*> \brief <b> CSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYSV_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csysv_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csysv_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csysv_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYSV_RK computes the solution to a complex system of linear
+*> equations A * X = B, where A is an N-by-N symmetric matrix
+*> and X and B are N-by-NRHS matrices.
+*>
+*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
+*> to factor A as
+*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
+*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> CSYTRF_RK is called to compute the factorization of a complex
+*> symmetric matrix. The factored form of A is then used to solve
+*> the system of equations A * X = B by calling BLAS3 routine CSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order 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,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, if INFO = 0, diagonal of the block diagonal
+*> matrix D and factors U or L as computed by CSYTRF_RK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> For more info see the description of CSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the output computed by the factorization
+*> routine CSYTRF_RK, i.e. the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*>
+*> For more info see the description of CSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by CSYTRF_RK.
+*>
+*> For more info see the description of CSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension ( MAX(1,LWORK) ).
+*> Work array used in the factorization stage.
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= 1. For best performance
+*> of factorization stage LWORK >= max(1,N*NB), where NB is
+*> the optimal blocksize for CSYTRF_RK.
+*>
+*> If LWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of the WORK
+*> array for factorization stage, 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, CSYTRF_RK, CSYTRS_3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYSV_RK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U**T or A = L*D*L**T.
+*
+ CALL CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B with BLAS3 solver, overwriting B with X.
+*
+ CALL CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of CSYSV_RK
+*
+ END
--- /dev/null
+*> \brief \b CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTF2_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytf2_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytf2_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytf2_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E ( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYTF2_RK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put further details
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept.,
+*> Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ REAL ABSAKK, ALPHA, COLMAX, ROWMAX, STEMP, SFMIN
+ COMPLEX D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ICAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ICAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CSCAL, CSWAP, CSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT, AIMAG, REAL
+* ..
+* .. Statement Functions ..
+ REAL CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( REAL( Z ) ) + ABS( AIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTF2_RK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 34
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ICAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ICAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ICAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ))
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL CSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL CSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL CSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL CSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL CSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+*
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL CSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+* Copy superdiagonal elements of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ E( K ) = A( K-1, K )
+ E( K-1 ) = CZERO
+ A( K-1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 34 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 64
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ICAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ICAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ICAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ STEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ))
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL CSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL CSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL CSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL CSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL CSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL CSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+*
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL CSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL CSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+* Copy subdiagonal elements of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ E( K ) = A( K+1, K )
+ E( K+1 ) = CZERO
+ A( K+1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ 64 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of CSYTF2_RK
+*
+ END
--- /dev/null
+*> \brief \b CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytrf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytrf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytrf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYTRF_RK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX 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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned
+*> by ILAENV.
+*>
+*> 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put correct description
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
+ $ NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLASYF_RK, CSYTF2_RK, CSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'CSYTRF_RK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRF_RK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'CSYTRF_RK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by CLASYF_RK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 15
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL CLASYF_RK( UPLO, K, NB, KB, A, LDA, E,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL CSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k-kb+1:k and apply row permutations to the
+* last k+1 colunms k+1:N after that block
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.LT.N ) THEN
+ DO I = K, ( K - KB + 1 ), -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( N-K, A( I, K+1 ), LDA,
+ $ A( IP, K+1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+* This label is the exit from main loop over K decreasing
+* from N to 1 in steps of KB
+*
+ 15 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by CLASYF_RK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 35
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL CLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+
+
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL CSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), IINFO )
+ KB = N - K + 1
+*
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO I = K, K + KB - 1
+ IF( IPIV( I ).GT.0 ) THEN
+ IPIV( I ) = IPIV( I ) + K - 1
+ ELSE
+ IPIV( I ) = IPIV( I ) - K + 1
+ END IF
+ END DO
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k:k+kb-1 and apply row permutations to the
+* first k-1 colunms 1:k-1 before that block
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.GT.1 ) THEN
+ DO I = K, ( K + KB - 1 ), 1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL CSWAP( K-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+* This label is the exit from main loop over K increasing
+* from 1 to N in steps of KB
+*
+ 35 CONTINUE
+*
+* End Lower
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of CSYTRF_RK
+*
+ END
--- /dev/null
+*> \brief \b CSYTRI_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRI_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytri_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytri_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytri_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYTRI_3 computes the inverse of a complex symmetric indefinite
+*> matrix A using the factorization computed by CSYTRF_RK or CSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> CSYTRI_3 sets the leading dimension of the workspace before calling
+*> CSYTRI_3X that actually computes the inverse. This is the blocked
+*> version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by CSYTRF_RK and CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_RK or CSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (N+NB+1)*(NB+3).
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= (N+NB+1)*(NB+3).
+*>
+*> If LDWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of 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
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL CSYTRI_3X
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* Determine the block size
+*
+ NB = MAX( 1, ILAENV( 1, 'CSYTRI_3', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = ( N+NB+1 ) * ( NB+3 )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRI_3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ WORK( 1 ) = LWKOPT
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ CALL CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of CSYTRI_3
+*
+ END
--- /dev/null
+*> \brief \b CSYTRI_3X
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRI_3X + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytri_3x.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytri_3x.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytri_3x.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYTRI_3X computes the inverse of a complex symmetric indefinite
+*> matrix A using the factorization computed by CSYTRF_RK or CSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by CSYTRF_RK and CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_RK or CSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (N+NB+1,NB+3).
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX CONE, CZERO
+ PARAMETER ( CONE = ( 1.0E+0, 0.0E+0 ),
+ $ CZERO = ( 0.0E+0, 0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11
+ COMPLEX AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J,
+ $ U11_I_J, U11_IP1_J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMM, CSYSWAPR, CTRTRI, CTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+*
+* Quick return if possible
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRI_3X', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Workspace got Non-diag elements of D
+*
+ DO K = 1, N
+ WORK( K, 1 ) = E( K )
+ END DO
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+ INFO = 0
+*
+* Splitting Workspace
+* U01 is a block ( N, NB+1 )
+* The first element of U01 is in WORK( 1, 1 )
+* U11 is a block ( NB+1, NB+1 )
+* The first element of U11 is in WORK( N+1, 1 )
+*
+ U11 = N
+*
+* INVD is a block ( N, 2 )
+* The first element of INVD is in WORK( 1, INVD )
+*
+ INVD = NB + 2
+
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* invA = P * inv(U**T) * inv(D) * inv(U) * P**T.
+*
+ CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(U)
+*
+ K = 1
+ DO WHILE( K.LE.N )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = CONE / A( K, K )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K+1, 1 )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = WORK( K+1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K, INVD ) = AKP1 / D
+ WORK( K+1, INVD+1 ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K+1, INVD ) = WORK( K, INVD+1 )
+ K = K + 1
+ END IF
+ K = K + 1
+ END DO
+*
+* inv(U**T) = (inv(U))**T
+*
+* inv(U**T) * inv(D) * inv(U)
+*
+ CUT = N
+ DO WHILE( CUT.GT.0 )
+ NNB = NB
+ IF( CUT.LE.NNB ) THEN
+ NNB = CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT+1-NNB, CUT
+ IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+
+ CUT = CUT - NNB
+*
+* U01 Block
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ WORK( I, J ) = A( I, CUT+J )
+ END DO
+ END DO
+*
+* U11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I ) = CONE
+ DO J = 1, I-1
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD * U01
+*
+ I = 1
+ DO WHILE( I.LE.CUT )
+ IF( IPIV( I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( I, INVD ) * WORK( I, J )
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK( I, J )
+ U01_IP1_J = WORK( I+1, J )
+ WORK( I, J ) = WORK( I, INVD ) * U01_I_J
+ $ + WORK( I, INVD+1 ) * U01_IP1_J
+ WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J
+ $ + WORK( I+1, INVD+1 ) * U01_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* invD1 * U11
+*
+ I = 1
+ DO WHILE ( I.LE.NNB )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = I, NNB
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ END DO
+ ELSE
+ DO J = I, NNB
+ U11_I_J = WORK(U11+I,J)
+ U11_IP1_J = WORK(U11+I+1,J)
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J)
+ WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J
+ $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* U11**T * invD1 * U11 -> U11
+*
+ CALL CTRMM( 'L', 'U', 'T', 'U', NNB, NNB,
+ $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+* U01**T * invD * U01 -> A( CUT+I, CUT+J )
+*
+ CALL CGEMM( 'T', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ),
+ $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1),
+ $ N+NB+1 )
+
+*
+* U11 = U11**T * invD1 * U11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J)
+ END DO
+ END DO
+*
+* U01 = U00**T * invD0 * U01
+*
+ CALL CTRMM( 'L', UPLO, 'T', 'U', CUT, NNB,
+ $ CONE, A, LDA, WORK, N+NB+1 )
+
+*
+* Update U01
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ A( I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+* Next Block
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(U**T) * inv(D) * inv(U) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Upper case.
+*
+* ( We can use a loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = 1, N
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T.
+*
+ CALL CTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(L)
+*
+ K = N
+ DO WHILE ( K .GE. 1 )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = CONE / A( K, K )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K-1, 1 )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = WORK( K-1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K-1, INVD ) = AKP1 / D
+ WORK( K, INVD ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K-1, INVD+1 ) = WORK( K, INVD+1 )
+ K = K - 1
+ END IF
+ K = K - 1
+ END DO
+*
+* inv(L**T) = (inv(L))**T
+*
+* inv(L**T) * inv(D) * inv(L)
+*
+ CUT = 0
+ DO WHILE( CUT.LT.N )
+ NNB = NB
+ IF( (CUT + NNB).GT.N ) THEN
+ NNB = N - CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT + 1, CUT+NNB
+ IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+*
+* L21 Block
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ WORK( I, J ) = A( CUT+NNB+I, CUT+J )
+ END DO
+ END DO
+*
+* L11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I) = CONE
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = 1, I-1
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD*L21
+*
+ I = N-CUT-NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+NNB+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J)
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK(I,J)
+ U01_IP1_J = WORK(I-1,J)
+ WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+
+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J
+ WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+
+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* invD1*L11
+*
+ I = NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J)
+ END DO
+
+ ELSE
+ DO J = 1, NNB
+ U11_I_J = WORK( U11+I, J )
+ U11_IP1_J = WORK( U11+I-1, J )
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * U11_IP1_J
+ WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J
+ $ + WORK(CUT+I-1,INVD) * U11_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* L11**T * invD1 * L11 -> L11
+*
+ CALL CTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, CONE,
+ $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+ IF( (CUT+NNB).LT.N ) THEN
+*
+* L21**T * invD2*L21 -> A( CUT+I, CUT+J )
+*
+ CALL CGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, CONE,
+ $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1,
+ $ CZERO, WORK( U11+1, 1 ), N+NB+1 )
+
+*
+* L11 = L11**T * invD1 * L11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J)
+ END DO
+ END DO
+*
+* L01 = L22**T * invD2 * L21
+*
+ CALL CTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, CONE,
+ $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK,
+ $ N+NB+1 )
+*
+* Update L21
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ A( CUT+NNB+I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+ ELSE
+*
+* L11 = L11**T * invD1 * L11
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+ END IF
+*
+* Next Block
+*
+ CUT = CUT + NNB
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(L**T) * inv(D) * inv(L) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Lower case.
+*
+* ( We can use a loop over IPIV with increment -1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = N, 1, -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL CSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of CSYTRI_3X
+*
+ END
+
--- /dev/null
+*> \brief \b CSYTRS_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CSYTRS_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/csytrs_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/csytrs_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/csytrs_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> CSYTRS_3 solves a system of linear equations A * X = B with a complex
+*> symmetric matrix A using the factorization computed
+*> by CSYTRF_RK or CSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This algorithm is using Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order 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] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by CSYTRF_RK and CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by CSYTRF_RK or CSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,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.
+*
+*> \date November 2016
+*
+*> \ingroup complexSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE CSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = ( 1.0E+0,0.0E+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J, K, KP
+ COMPLEX AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL CSCAL, CSWAP, CTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'CSYTRS_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* P**T * B
+*
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
+*
+ CALL CTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (U \P**T * B) ]
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL CSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF ( I.GT.1 ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I-1, I-1 ) / AKM1K
+ AK = A( I, I ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I-1, J ) / AKM1K
+ BK = B( I, J ) / AKM1K
+ B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ]
+*
+ CALL CTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* P**T * B
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
+*
+ CALL CTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (L \P**T * B) ]
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL CSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF( I.LT.N ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I, I ) / AKM1K
+ AK = A( I+1, I+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I, J ) / AKM1K
+ BK = B( I+1, J ) / AKM1K
+ B( I, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ]
+*
+ CALL CTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL CSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* END Lower
+*
+ END IF
+*
+ RETURN
+*
+* End of CSYTRS_3
+*
+ END
--- /dev/null
+*> \brief \b DLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DLASYF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlasyf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlasyf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlasyf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DLASYF_RK computes a partial factorization of a real symmetric
+*> matrix A using the bounded Bunch-Kaufman (rook) diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L',
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> DLASYF_RK is an auxiliary routine called by DSYTRF_RK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,N-KB+1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,N-KB+1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,N-KB+1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,1:KB).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is DOUBLE PRECISION array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW,
+ $ KP, KSTEP, P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ DTEMP, R1, ROWMAX, T, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = ZERO
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = ABS( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL DGEMV( 'No transpose', K, N-K, -ONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ ONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = ABS( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ DTEMP = ABS( W( ITEMP, KW-1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL DCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL DCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL DSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL DSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = ONE / ( D11*D22-ONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy superdiagonal element of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = ZERO
+ A( K, K ) = W( K, KW )
+ E( K ) = W( K-1, KW )
+ E( K-1 ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ),
+ $ LDW, ONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = ZERO
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = ABS( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ ONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = ABS( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ DTEMP = ABS( W( ITEMP, K+1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL DCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL DCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL DSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL DSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy subdiagonal element of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = ZERO
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ E( K ) = W( K+1, K )
+ E( K+1 ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, ONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+*
+ RETURN
+*
+* End of DLASYF_RK
+*
+ END
--- /dev/null
+*> \brief \b DSYCON_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYCON_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsycon_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsycon_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsycon_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYCON_3 estimates the reciprocal of the condition number (in the
+*> 1-norm) of a real symmetric matrix A using the factorization
+*> computed by DSYTRF_RK or DSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> This routine uses BLAS3 solver DSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by DSYTRF_RK and DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_RK or DSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is DOUBLE PRECISION
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is DOUBLE PRECISION
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER 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.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DSYTRS_3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYCON_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL DSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DSYCON_3
+*
+ END
--- /dev/null
+*> \brief \b DSYCONVF
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYCONVF + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsyconvf.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsyconvf.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsyconvf.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> DSYCONVF converts the factorization output format used in
+*> DSYTRF provided on entry in parameter A into the factorization
+*> output format used in DSYTRF_RK (or DSYTRF_BK) that is stored
+*> on exit in parameters A and E. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in DSYTRF into
+*> the format used in DSYTRF_RK (or DSYTRF_BK).
+*>
+*> If parameter WAY = 'R':
+*> DSYCONVF performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in DSYTRF_RK
+*> (or DSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in DSYTRF that is stored
+*> on exit in parameter A. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in DSYTRF_RK
+*> (or DSYTRF_BK) into the format used in DSYTRF.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> DSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> DSYTRF_RK or DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> DSYTRF_RK or DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> DSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in,out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in DSYTRF.
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in DSYTRF_RK
+*> ( or DSYTRF_BK).
+*>
+*> 1) If WAY ='R':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in DSYTRF_RK
+*> ( or DSYTRF_BK).
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in DSYTRF.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE DSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL DSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYCONVF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL DSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL DSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i-1 and IPIV(i-1),
+* so this should be recorded in two consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I-1 )
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where k increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL DSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL DSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i+1 and IPIV(i+1),
+* so this should be recorded in consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I+1 )
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of DSYCONVF
+*
+ END
--- /dev/null
+*> \brief \b DSYCONVF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYCONVF_ROOK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsyconvf_rook.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsyconvf_rook.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsyconvf_rook.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> DSYCONVF_ROOK converts the factorization output format used in
+*> DSYTRF_ROOK provided on entry in parameter A into the factorization
+*> output format used in DSYTRF_RK (or DSYTRF_BK) that is stored
+*> on exit in parameters A and E. IPIV format for DSYTRF_ROOK and
+*> DSYTRF_RK (or DSYTRF_BK) is the same and is not converted.
+*>
+*> If parameter WAY = 'R':
+*> DSYCONVF_ROOK performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in DSYTRF_RK
+*> (or DSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in DSYTRF_ROOK that is stored
+*> on exit in parameter A. IPIV format for DSYTRF_ROOK and
+*> DSYTRF_RK (or DSYTRF_BK) is the same and is not converted.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> DSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> DSYTRF_RK or DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> DSYTRF_RK or DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> DSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> On entry, details of the interchanges and the block
+*> structure of D as determined:
+*> 1) by DSYTRF_ROOK, if WAY ='C';
+*> 2) by DSYTRF_RK (or DSYTRF_BK), if WAY ='R'.
+*> The IPIV format is the same for all these routines.
+*>
+*> On exit, is not changed.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE DSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL DSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP, IP2
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYCONVF_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i-1 and IPIV(i-1)
+* in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ IF( IP2.NE.(I-1) ) THEN
+ CALL DSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP2, I+1 ), LDA )
+ END IF
+ END IF
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i-1) and i and IPIV(i)
+* in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP2.NE.(I-1) ) THEN
+ CALL DSWAP( N-I, A( IP2, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i+1 and IPIV(i+1)
+* in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ IF( IP2.NE.(I+1) ) THEN
+ CALL DSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP2, 1 ), LDA )
+ END IF
+ END IF
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i+1) and i and IPIV(i)
+* in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP2.NE.(I+1) ) THEN
+ CALL DSWAP( I-1, A( IP2, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of DSYCONVF_ROOK
+*
+ END
--- /dev/null
+*> \brief <b> DSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYSV_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsysv_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsysv_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsysv_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYSV_RK computes the solution to a real system of linear
+*> equations A * X = B, where A is an N-by-N symmetric matrix
+*> and X and B are N-by-NRHS matrices.
+*>
+*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
+*> to factor A as
+*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
+*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> DSYTRF_RK is called to compute the factorization of a real
+*> symmetric matrix. The factored form of A is then used to solve
+*> the system of equations A * X = B by calling BLAS3 routine DSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order 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,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, if INFO = 0, diagonal of the block diagonal
+*> matrix D and factors U or L as computed by DSYTRF_RK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> For more info see the description of DSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On exit, contains the output computed by the factorization
+*> routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*>
+*> For more info see the description of DSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by DSYTRF_RK.
+*>
+*> For more info see the description of DSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ).
+*> Work array used in the factorization stage.
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= 1. For best performance
+*> of factorization stage LWORK >= max(1,N*NB), where NB is
+*> the optimal blocksize for DSYTRF_RK.
+*>
+*> If LWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of the WORK
+*> array for factorization stage, 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, DSYTRF_RK, DSYTRS_3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYSV_RK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = P*U*D*(U**T)*(P**T) or
+* A = P*U*D*(U**T)*(P**T).
+*
+ CALL DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B with BLAS3 solver, overwriting B with X.
+*
+ CALL DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYSV_RK
+*
+ END
--- /dev/null
+*> \brief \b DSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTF2_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytf2_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytf2_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytf2_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E ( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYTF2_RK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put further details
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept.,
+*> Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ ROWMAX, DTEMP, T, WK, WKM1, WKP1, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, DSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTF2_RK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = ZERO
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 34
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ DTEMP = ABS( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL DSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL DSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL DSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL DSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+*
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL DSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL DSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+* Copy superdiagonal elements of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ E( K ) = A( K-1, K )
+ E( K-1 ) = ZERO
+ A( K-1, K ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 34 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = ZERO
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 64
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ DTEMP = ABS( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL DSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL DSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL DSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL DSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+*
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+* Copy subdiagonal elements of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ E( K ) = A( K+1, K )
+ E( K+1 ) = ZERO
+ A( K+1, K ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ 64 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of DSYTF2_RK
+*
+ END
--- /dev/null
+*> \brief \b DSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYTRF_RK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned
+*> by ILAENV.
+*>
+*> 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put correct description
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
+ $ NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASYF_RK, DSYTF2_RK, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'DSYTRF_RK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRF_RK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF_RK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by DLASYF_RK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 15
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL DLASYF_RK( UPLO, K, NB, KB, A, LDA, E,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL DSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k-kb+1:k and apply row permutations to the
+* last k+1 colunms k+1:N after that block
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.LT.N ) THEN
+ DO I = K, ( K - KB + 1 ), -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( N-K, A( I, K+1 ), LDA,
+ $ A( IP, K+1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+* This label is the exit from main loop over K decreasing
+* from N to 1 in steps of KB
+*
+ 15 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by DLASYF_RK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 35
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL DLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+
+
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL DSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), IINFO )
+ KB = N - K + 1
+*
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO I = K, K + KB - 1
+ IF( IPIV( I ).GT.0 ) THEN
+ IPIV( I ) = IPIV( I ) + K - 1
+ ELSE
+ IPIV( I ) = IPIV( I ) - K + 1
+ END IF
+ END DO
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k:k+kb-1 and apply row permutations to the
+* first k-1 colunms 1:k-1 before that block
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.GT.1 ) THEN
+ DO I = K, ( K + KB - 1 ), 1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL DSWAP( K-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+* This label is the exit from main loop over K increasing
+* from 1 to N in steps of KB
+*
+ 35 CONTINUE
+*
+* End Lower
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DSYTRF_RK
+*
+ END
--- /dev/null
+*> \brief \b DSYTRI_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRI_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytri_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytri_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytri_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYTRI_3 computes the inverse of a real symmetric indefinite
+*> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> DSYTRI_3 sets the leading dimension of the workspace before calling
+*> DSYTRI_3X that actually computes the inverse. This is the blocked
+*> version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by DSYTRF_RK and DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_RK or DSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3).
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= (N+NB+1)*(NB+3).
+*>
+*> If LDWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of 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
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSYTRI_3X
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* Determine the block size
+*
+ NB = MAX( 1, ILAENV( 1, 'DSYTRI_3', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = ( N+NB+1 ) * ( NB+3 )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRI_3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ WORK( 1 ) = LWKOPT
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ CALL DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYTRI_3
+*
+ END
--- /dev/null
+*> \brief \b DSYTRI_3X
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRI_3X + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytri_3x.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytri_3x.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytri_3x.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYTRI_3X computes the inverse of a real symmetric indefinite
+*> matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by DSYTRF_RK and DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_RK or DSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3).
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11
+ DOUBLE PRECISION AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J,
+ $ U11_I_J, U11_IP1_J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DSYSWAPR, DTRTRI, DTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+*
+* Quick return if possible
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRI_3X', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Workspace got Non-diag elements of D
+*
+ DO K = 1, N
+ WORK( K, 1 ) = E( K )
+ END DO
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+ INFO = 0
+*
+* Splitting Workspace
+* U01 is a block ( N, NB+1 )
+* The first element of U01 is in WORK( 1, 1 )
+* U11 is a block ( NB+1, NB+1 )
+* The first element of U11 is in WORK( N+1, 1 )
+*
+ U11 = N
+*
+* INVD is a block ( N, 2 )
+* The first element of INVD is in WORK( 1, INVD )
+*
+ INVD = NB + 2
+
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* invA = P * inv(U**T) * inv(D) * inv(U) * P**T.
+*
+ CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(U)
+*
+ K = 1
+ DO WHILE( K.LE.N )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / A( K, K )
+ WORK( K, INVD+1 ) = ZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K+1, 1 )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = WORK( K+1, 1 ) / T
+ D = T*( AK*AKP1-ONE )
+ WORK( K, INVD ) = AKP1 / D
+ WORK( K+1, INVD+1 ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K+1, INVD ) = WORK( K, INVD+1 )
+ K = K + 1
+ END IF
+ K = K + 1
+ END DO
+*
+* inv(U**T) = (inv(U))**T
+*
+* inv(U**T) * inv(D) * inv(U)
+*
+ CUT = N
+ DO WHILE( CUT.GT.0 )
+ NNB = NB
+ IF( CUT.LE.NNB ) THEN
+ NNB = CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT+1-NNB, CUT
+ IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+
+ CUT = CUT - NNB
+*
+* U01 Block
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ WORK( I, J ) = A( I, CUT+J )
+ END DO
+ END DO
+*
+* U11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I ) = ONE
+ DO J = 1, I-1
+ WORK( U11+I, J ) = ZERO
+ END DO
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD * U01
+*
+ I = 1
+ DO WHILE( I.LE.CUT )
+ IF( IPIV( I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( I, INVD ) * WORK( I, J )
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK( I, J )
+ U01_IP1_J = WORK( I+1, J )
+ WORK( I, J ) = WORK( I, INVD ) * U01_I_J
+ $ + WORK( I, INVD+1 ) * U01_IP1_J
+ WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J
+ $ + WORK( I+1, INVD+1 ) * U01_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* invD1 * U11
+*
+ I = 1
+ DO WHILE ( I.LE.NNB )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = I, NNB
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ END DO
+ ELSE
+ DO J = I, NNB
+ U11_I_J = WORK(U11+I,J)
+ U11_IP1_J = WORK(U11+I+1,J)
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J)
+ WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J
+ $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* U11**T * invD1 * U11 -> U11
+*
+ CALL DTRMM( 'L', 'U', 'T', 'U', NNB, NNB,
+ $ ONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+* U01**T * invD * U01 -> A( CUT+I, CUT+J )
+*
+ CALL DGEMM( 'T', 'N', NNB, NNB, CUT, ONE, A( 1, CUT+1 ),
+ $ LDA, WORK, N+NB+1, ZERO, WORK(U11+1,1), N+NB+1 )
+
+*
+* U11 = U11**T * invD1 * U11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J)
+ END DO
+ END DO
+*
+* U01 = U00**T * invD0 * U01
+*
+ CALL DTRMM( 'L', UPLO, 'T', 'U', CUT, NNB,
+ $ ONE, A, LDA, WORK, N+NB+1 )
+
+*
+* Update U01
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ A( I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+* Next Block
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(U**T) * inv(D) * inv(U) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Upper case.
+*
+* ( We can use a loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = 1, N
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T.
+*
+ CALL DTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(L)
+*
+ K = N
+ DO WHILE ( K .GE. 1 )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / A( K, K )
+ WORK( K, INVD+1 ) = ZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K-1, 1 )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = WORK( K-1, 1 ) / T
+ D = T*( AK*AKP1-ONE )
+ WORK( K-1, INVD ) = AKP1 / D
+ WORK( K, INVD ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K-1, INVD+1 ) = WORK( K, INVD+1 )
+ K = K - 1
+ END IF
+ K = K - 1
+ END DO
+*
+* inv(L**T) = (inv(L))**T
+*
+* inv(L**T) * inv(D) * inv(L)
+*
+ CUT = 0
+ DO WHILE( CUT.LT.N )
+ NNB = NB
+ IF( (CUT + NNB).GT.N ) THEN
+ NNB = N - CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT + 1, CUT+NNB
+ IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+*
+* L21 Block
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ WORK( I, J ) = A( CUT+NNB+I, CUT+J )
+ END DO
+ END DO
+*
+* L11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I) = ONE
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = ZERO
+ END DO
+ DO J = 1, I-1
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD*L21
+*
+ I = N-CUT-NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+NNB+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J)
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK(I,J)
+ U01_IP1_J = WORK(I-1,J)
+ WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+
+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J
+ WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+
+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* invD1*L11
+*
+ I = NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J)
+ END DO
+
+ ELSE
+ DO J = 1, NNB
+ U11_I_J = WORK( U11+I, J )
+ U11_IP1_J = WORK( U11+I-1, J )
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * U11_IP1_J
+ WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J
+ $ + WORK(CUT+I-1,INVD) * U11_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* L11**T * invD1 * L11 -> L11
+*
+ CALL DTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, ONE,
+ $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+ IF( (CUT+NNB).LT.N ) THEN
+*
+* L21**T * invD2*L21 -> A( CUT+I, CUT+J )
+*
+ CALL DGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, ONE,
+ $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1,
+ $ ZERO, WORK( U11+1, 1 ), N+NB+1 )
+
+*
+* L11 = L11**T * invD1 * L11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J)
+ END DO
+ END DO
+*
+* L01 = L22**T * invD2 * L21
+*
+ CALL DTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, ONE,
+ $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK,
+ $ N+NB+1 )
+*
+* Update L21
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ A( CUT+NNB+I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+ ELSE
+*
+* L11 = L11**T * invD1 * L11
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+ END IF
+*
+* Next Block
+*
+ CUT = CUT + NNB
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(L**T) * inv(D) * inv(L) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Lower case.
+*
+* ( We can use a loop over IPIV with increment -1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = N, 1, -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL DSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of DSYTRI_3X
+*
+ END
+
--- /dev/null
+*> \brief \b DSYTRS_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DSYTRS_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dsytrs_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dsytrs_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dsytrs_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DSYTRS_3 solves a system of linear equations A * X = B with a real
+*> symmetric matrix A using the factorization computed
+*> by DSYTRF_RK or DSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This algorithm is using Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order 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] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by DSYTRF_RK and DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by DSYTRF_RK or DSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,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.
+*
+*> \date November 2016
+*
+*> \ingroup doubleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J, K, KP
+ DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRS_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* P**T * B
+*
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
+*
+ CALL DTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (U \P**T * B) ]
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF ( I.GT.1 ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I-1, I-1 ) / AKM1K
+ AK = A( I, I ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I-1, J ) / AKM1K
+ BK = B( I, J ) / AKM1K
+ B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ]
+*
+ CALL DTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* P**T * B
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
+*
+ CALL DTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (L \P**T * B) ]
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL DSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF( I.LT.N ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I, I ) / AKM1K
+ AK = A( I+1, I+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I, J ) / AKM1K
+ BK = B( I+1, J ) / AKM1K
+ B( I, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ]
+*
+ CALL DTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* END Lower
+*
+ END IF
+*
+ RETURN
+*
+* End of DSYTRS_3
+*
+ END
--- /dev/null
+*> \brief \b SLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SLASYF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slasyf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slasyf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slasyf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SLASYF_RK computes a partial factorization of a real symmetric
+*> matrix A using the bounded Bunch-Kaufman (rook) diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L',
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> SLASYF_RK is an auxiliary routine called by SSYTRF_RK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,N-KB+1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,N-KB+1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,N-KB+1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,1:KB).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is REAL array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW,
+ $ KP, KSTEP, P, II
+ REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ STEMP, R1, ROWMAX, T, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = ZERO
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = ABS( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL SGEMV( 'No transpose', K, N-K, -ONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ ONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = ABS( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ISAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ STEMP = ABS( W( ITEMP, KW-1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(ABS( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL SCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL SCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL SSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL SSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL SSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = ONE / ( D11*D22-ONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy superdiagonal element of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = ZERO
+ A( K, K ) = W( K, KW )
+ E( K ) = W( K-1, KW )
+ E( K-1 ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL SGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -ONE, A( 1, K+1 ), LDA, W( J, KW+1 ),
+ $ LDW, ONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = ZERO
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = ABS( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ ONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ISAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = ABS( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ISAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ STEMP = ABS( W( ITEMP, K+1 ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL SCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL SCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL SSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL SSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = ONE / A( K, K )
+ CALL SSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.ZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy subdiagonal element of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = ZERO
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ E( K ) = W( K+1, K )
+ E( K+1 ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, ONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+*
+ RETURN
+*
+* End of SLASYF_RK
+*
+ END
--- /dev/null
+*> \brief \b SSYCON_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYCON_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssycon_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssycon_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssycon_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* REAL A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYCON_3 estimates the reciprocal of the condition number (in the
+*> 1-norm) of a real symmetric matrix A using the factorization
+*> computed by DSYTRF_RK or DSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> This routine uses BLAS3 solver SSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by SSYTRF_RK and SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_RK or SSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is REAL
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is REAL
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER 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.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SSYTRS_3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYCON_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL SSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DSYCON_3
+*
+ END
--- /dev/null
+*> \brief \b SSYCONVF
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYCONVF + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyconvf.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyconvf.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyconvf.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> SSYCONVF converts the factorization output format used in
+*> SSYTRF provided on entry in parameter A into the factorization
+*> output format used in SSYTRF_RK (or SSYTRF_BK) that is stored
+*> on exit in parameters A and E. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in SSYTRF into
+*> the format used in SSYTRF_RK (or SSYTRF_BK).
+*>
+*> If parameter WAY = 'R':
+*> SSYCONVF performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in SSYTRF_RK
+*> (or SSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in SSYTRF that is stored
+*> on exit in parameter A. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in SSYTRF_RK
+*> (or SSYTRF_BK) into the format used in SSYTRF.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> SSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> SSYTRF_RK or SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> SSYTRF_RK or SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> SSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in,out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in SSYTRF.
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in SSYTRF_RK
+*> ( or SSYTRF_BK).
+*>
+*> 1) If WAY ='R':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in SSYTRF_RK
+*> ( or SSYTRF_BK).
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in SSYTRF.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE SSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL SSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYCONVF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL SSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL SSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i-1 and IPIV(i-1),
+* so this should be recorded in two consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I-1 )
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where k increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL SSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL SSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i+1 and IPIV(i+1),
+* so this should be recorded in consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I+1 )
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of SSYCONVF
+*
+ END
--- /dev/null
+*> \brief \b SSYCONVF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYCONVF_ROOK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyconvf_rook.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyconvf_rook.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyconvf_rook.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> SSYCONVF_ROOK converts the factorization output format used in
+*> SSYTRF_ROOK provided on entry in parameter A into the factorization
+*> output format used in SSYTRF_RK (or SSYTRF_BK) that is stored
+*> on exit in parameters A and E. IPIV format for SSYTRF_ROOK and
+*> SSYTRF_RK (or SSYTRF_BK) is the same and is not converted.
+*>
+*> If parameter WAY = 'R':
+*> SSYCONVF_ROOK performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in SSYTRF_RK
+*> (or SSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in SSYTRF_ROOK that is stored
+*> on exit in parameter A. IPIV format for SSYTRF_ROOK and
+*> SSYTRF_RK (or SSYTRF_BK) is the same and is not converted.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> SSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> SSYTRF_RK or SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> SSYTRF_RK or SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> SSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> On entry, details of the interchanges and the block
+*> structure of D as determined:
+*> 1) by SSYTRF_ROOK, if WAY ='C';
+*> 2) by SSYTRF_RK (or SSYTRF_BK), if WAY ='R'.
+*> The IPIV format is the same for all these routines.
+*>
+*> On exit, is not changed.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL SSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP, IP2
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYCONVF_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i-1 and IPIV(i-1)
+* in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ IF( IP2.NE.(I-1) ) THEN
+ CALL SSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP2, I+1 ), LDA )
+ END IF
+ END IF
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i-1) and i and IPIV(i)
+* in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP2.NE.(I-1) ) THEN
+ CALL SSWAP( N-I, A( IP2, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i+1 and IPIV(i+1)
+* in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ IF( IP2.NE.(I+1) ) THEN
+ CALL SSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP2, 1 ), LDA )
+ END IF
+ END IF
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i+1) and i and IPIV(i)
+* in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP2.NE.(I+1) ) THEN
+ CALL SSWAP( I-1, A( IP2, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of SSYCONVF_ROOK
+*
+ END
--- /dev/null
+*> \brief <b> SSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYSV_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYSV_RK computes the solution to a real system of linear
+*> equations A * X = B, where A is an N-by-N symmetric matrix
+*> and X and B are N-by-NRHS matrices.
+*>
+*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
+*> to factor A as
+*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
+*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> SSYTRF_RK is called to compute the factorization of a real
+*> symmetric matrix. The factored form of A is then used to solve
+*> the system of equations A * X = B by calling BLAS3 routine SSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order 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,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, if INFO = 0, diagonal of the block diagonal
+*> matrix D and factors U or L as computed by SSYTRF_RK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> For more info see the description of DSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On exit, contains the output computed by the factorization
+*> routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*>
+*> For more info see the description of DSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by SSYTRF_RK.
+*>
+*> For more info see the description of DSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension ( MAX(1,LWORK) ).
+*> Work array used in the factorization stage.
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= 1. For best performance
+*> of factorization stage LWORK >= max(1,N*NB), where NB is
+*> the optimal blocksize for DSYTRF_RK.
+*>
+*> If LWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of the WORK
+*> array for factorization stage, 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, SSYTRF_RK, SSYTRS_3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYSV_RK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = P*U*D*(U**T)*(P**T) or
+* A = P*U*D*(U**T)*(P**T).
+*
+ CALL SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B with BLAS3 solver, overwriting B with X.
+*
+ CALL SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYSV_RK
+*
+ END
--- /dev/null
+*> \brief \b SSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTF2_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytf2_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytf2_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytf2_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E ( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYTF2_RK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put further details
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept.,
+*> Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22,
+ $ ROWMAX, STEMP, T, WK, WKM1, WKP1, SFMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, SSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTF2_RK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = ZERO
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 34
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = ISAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ STEMP = ABS( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL SSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL SSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL SSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL SSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+*
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL SSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL SSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+* Copy superdiagonal elements of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ E( K ) = A( K-1, K )
+ E( K-1 ) = ZERO
+ A( K-1, K ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 34 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = ZERO
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 64
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = ZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ STEMP = ABS( A( ITEMP, IMAX ) )
+ IF( STEMP.GT.ROWMAX ) THEN
+ ROWMAX = STEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( ABS( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL SSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL SSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL SSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL SSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+*
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( ABS( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / A( K, K )
+ CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL SSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = ZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+* Copy subdiagonal elements of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ E( K ) = A( K+1, K )
+ E( K+1 ) = ZERO
+ A( K+1, K ) = ZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ 64 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of SSYTF2_RK
+*
+ END
--- /dev/null
+*> \brief \b SSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYTRF_RK computes the factorization of a real symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL 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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned
+*> by ILAENV.
+*>
+*> 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put correct description
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
+ $ NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASYF_RK, SSYTF2_RK, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'SSYTRF_RK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRF_RK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'SSYTRF_RK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by SLASYF_RK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 15
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL SLASYF_RK( UPLO, K, NB, KB, A, LDA, E,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL SSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k-kb+1:k and apply row permutations to the
+* last k+1 colunms k+1:N after that block
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.LT.N ) THEN
+ DO I = K, ( K - KB + 1 ), -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( N-K, A( I, K+1 ), LDA,
+ $ A( IP, K+1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+* This label is the exit from main loop over K decreasing
+* from N to 1 in steps of KB
+*
+ 15 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by SLASYF_RK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 35
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL SLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+
+
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL SSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), IINFO )
+ KB = N - K + 1
+*
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO I = K, K + KB - 1
+ IF( IPIV( I ).GT.0 ) THEN
+ IPIV( I ) = IPIV( I ) + K - 1
+ ELSE
+ IPIV( I ) = IPIV( I ) - K + 1
+ END IF
+ END DO
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k:k+kb-1 and apply row permutations to the
+* first k-1 colunms 1:k-1 before that block
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.GT.1 ) THEN
+ DO I = K, ( K + KB - 1 ), 1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL SSWAP( K-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+* This label is the exit from main loop over K increasing
+* from 1 to N in steps of KB
+*
+ 35 CONTINUE
+*
+* End Lower
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SSYTRF_RK
+*
+ END
--- /dev/null
+*> \brief \b SSYTRI_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRI_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytri_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytri_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytri_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYTRI_3 computes the inverse of a real symmetric indefinite
+*> matrix A using the factorization computed by SSYTRF_RK or SSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> SSYTRI_3 sets the leading dimension of the workspace before calling
+*> SSYTRI_3X that actually computes the inverse. This is the blocked
+*> version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by SSYTRF_RK and SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_RK or SSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (N+NB+1)*(NB+3).
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= (N+NB+1)*(NB+3).
+*>
+*> If LDWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of 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
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSYTRI_3X
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* Determine the block size
+*
+ NB = MAX( 1, ILAENV( 1, 'SSYTRI_3', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = ( N+NB+1 ) * ( NB+3 )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRI_3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ WORK( 1 ) = LWKOPT
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ CALL SSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYTRI_3
+*
+ END
--- /dev/null
+*> \brief \b SSYTRI_3X
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRI_3X + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytri_3x.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytri_3x.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytri_3x.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYTRI_3X computes the inverse of a real symmetric indefinite
+*> matrix A using the factorization computed by SSYTRF_RK or SSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by SYTRF_RK and SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_RK or SSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (N+NB+1,NB+3).
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE SSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11
+ REAL AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J,
+ $ U11_I_J, U11_IP1_J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SSYSWAPR, STRTRI, STRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+*
+* Quick return if possible
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRI_3X', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Workspace got Non-diag elements of D
+*
+ DO K = 1, N
+ WORK( K, 1 ) = E( K )
+ END DO
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+ INFO = 0
+*
+* Splitting Workspace
+* U01 is a block ( N, NB+1 )
+* The first element of U01 is in WORK( 1, 1 )
+* U11 is a block ( NB+1, NB+1 )
+* The first element of U11 is in WORK( N+1, 1 )
+*
+ U11 = N
+*
+* INVD is a block ( N, 2 )
+* The first element of INVD is in WORK( 1, INVD )
+*
+ INVD = NB + 2
+
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* invA = P * inv(U**T) * inv(D) * inv(U) * P**T.
+*
+ CALL STRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(U)
+*
+ K = 1
+ DO WHILE( K.LE.N )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / A( K, K )
+ WORK( K, INVD+1 ) = ZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K+1, 1 )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = WORK( K+1, 1 ) / T
+ D = T*( AK*AKP1-ONE )
+ WORK( K, INVD ) = AKP1 / D
+ WORK( K+1, INVD+1 ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K+1, INVD ) = WORK( K, INVD+1 )
+ K = K + 1
+ END IF
+ K = K + 1
+ END DO
+*
+* inv(U**T) = (inv(U))**T
+*
+* inv(U**T) * inv(D) * inv(U)
+*
+ CUT = N
+ DO WHILE( CUT.GT.0 )
+ NNB = NB
+ IF( CUT.LE.NNB ) THEN
+ NNB = CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT+1-NNB, CUT
+ IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+
+ CUT = CUT - NNB
+*
+* U01 Block
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ WORK( I, J ) = A( I, CUT+J )
+ END DO
+ END DO
+*
+* U11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I ) = ONE
+ DO J = 1, I-1
+ WORK( U11+I, J ) = ZERO
+ END DO
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD * U01
+*
+ I = 1
+ DO WHILE( I.LE.CUT )
+ IF( IPIV( I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( I, INVD ) * WORK( I, J )
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK( I, J )
+ U01_IP1_J = WORK( I+1, J )
+ WORK( I, J ) = WORK( I, INVD ) * U01_I_J
+ $ + WORK( I, INVD+1 ) * U01_IP1_J
+ WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J
+ $ + WORK( I+1, INVD+1 ) * U01_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* invD1 * U11
+*
+ I = 1
+ DO WHILE ( I.LE.NNB )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = I, NNB
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ END DO
+ ELSE
+ DO J = I, NNB
+ U11_I_J = WORK(U11+I,J)
+ U11_IP1_J = WORK(U11+I+1,J)
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J)
+ WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J
+ $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* U11**T * invD1 * U11 -> U11
+*
+ CALL STRMM( 'L', 'U', 'T', 'U', NNB, NNB,
+ $ ONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+* U01**T * invD * U01 -> A( CUT+I, CUT+J )
+*
+ CALL SGEMM( 'T', 'N', NNB, NNB, CUT, ONE, A( 1, CUT+1 ),
+ $ LDA, WORK, N+NB+1, ZERO, WORK(U11+1,1), N+NB+1 )
+
+*
+* U11 = U11**T * invD1 * U11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J)
+ END DO
+ END DO
+*
+* U01 = U00**T * invD0 * U01
+*
+ CALL STRMM( 'L', UPLO, 'T', 'U', CUT, NNB,
+ $ ONE, A, LDA, WORK, N+NB+1 )
+
+*
+* Update U01
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ A( I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+* Next Block
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(U**T) * inv(D) * inv(U) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Upper case.
+*
+* ( We can use a loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = 1, N
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T.
+*
+ CALL STRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(L)
+*
+ K = N
+ DO WHILE ( K .GE. 1 )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / A( K, K )
+ WORK( K, INVD+1 ) = ZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K-1, 1 )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = WORK( K-1, 1 ) / T
+ D = T*( AK*AKP1-ONE )
+ WORK( K-1, INVD ) = AKP1 / D
+ WORK( K, INVD ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K-1, INVD+1 ) = WORK( K, INVD+1 )
+ K = K - 1
+ END IF
+ K = K - 1
+ END DO
+*
+* inv(L**T) = (inv(L))**T
+*
+* inv(L**T) * inv(D) * inv(L)
+*
+ CUT = 0
+ DO WHILE( CUT.LT.N )
+ NNB = NB
+ IF( (CUT + NNB).GT.N ) THEN
+ NNB = N - CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT + 1, CUT+NNB
+ IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+*
+* L21 Block
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ WORK( I, J ) = A( CUT+NNB+I, CUT+J )
+ END DO
+ END DO
+*
+* L11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I) = ONE
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = ZERO
+ END DO
+ DO J = 1, I-1
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD*L21
+*
+ I = N-CUT-NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+NNB+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J)
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK(I,J)
+ U01_IP1_J = WORK(I-1,J)
+ WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+
+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J
+ WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+
+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* invD1*L11
+*
+ I = NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J)
+ END DO
+
+ ELSE
+ DO J = 1, NNB
+ U11_I_J = WORK( U11+I, J )
+ U11_IP1_J = WORK( U11+I-1, J )
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * U11_IP1_J
+ WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J
+ $ + WORK(CUT+I-1,INVD) * U11_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* L11**T * invD1 * L11 -> L11
+*
+ CALL STRMM( 'L', UPLO, 'T', 'U', NNB, NNB, ONE,
+ $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+ IF( (CUT+NNB).LT.N ) THEN
+*
+* L21**T * invD2*L21 -> A( CUT+I, CUT+J )
+*
+ CALL SGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, ONE,
+ $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1,
+ $ ZERO, WORK( U11+1, 1 ), N+NB+1 )
+
+*
+* L11 = L11**T * invD1 * L11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J)
+ END DO
+ END DO
+*
+* L01 = L22**T * invD2 * L21
+*
+ CALL STRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, ONE,
+ $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK,
+ $ N+NB+1 )
+*
+* Update L21
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ A( CUT+NNB+I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+ ELSE
+*
+* L11 = L11**T * invD1 * L11
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+ END IF
+*
+* Next Block
+*
+ CUT = CUT + NNB
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(L**T) * inv(D) * inv(L) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Lower case.
+*
+* ( We can use a loop over IPIV with increment -1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = N, 1, -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL SSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of SSYTRI_3X
+*
+ END
+
--- /dev/null
+*> \brief \b SSYTRS_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SSYTRS_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SSYTRS_3 solves a system of linear equations A * X = B with a real
+*> symmetric matrix A using the factorization computed
+*> by SSYTRF_RK or SSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This algorithm is using Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order 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] A
+*> \verbatim
+*> A is REAL array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by SSYTRF_RK and SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is REAL array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by SSYTRF_RK or SSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is REAL array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,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.
+*
+*> \date November 2016
+*
+*> \ingroup singleSYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* ====================================================================
+ SUBROUTINE SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J, K, KP
+ REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRS_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* P**T * B
+*
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
+*
+ CALL STRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (U \P**T * B) ]
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL SSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF ( I.GT.1 ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I-1, I-1 ) / AKM1K
+ AK = A( I, I ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I-1, J ) / AKM1K
+ BK = B( I, J ) / AKM1K
+ B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ]
+*
+ CALL STRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* P**T * B
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
+*
+ CALL STRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (L \P**T * B) ]
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL SSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF( I.LT.N ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I, I ) / AKM1K
+ AK = A( I+1, I+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I, J ) / AKM1K
+ BK = B( I+1, J ) / AKM1K
+ B( I, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ]
+*
+ CALL STRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* END Lower
+*
+ END IF
+*
+ RETURN
+*
+* End of SSYTRS_3
+*
+ END
--- /dev/null
+*> \brief \b ZHECON_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHECON_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhecon_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhecon_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhecon_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHECON_3 estimates the reciprocal of the condition number (in the
+*> 1-norm) of a complex Hermitian matrix A using the factorization
+*> computed by ZHETRF_RK or ZHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> This routine uses BLAS3 solver ZHETRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by ZHETRF_RK and ZHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZHETRF_RK or ZHETRF_BK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is DOUBLE PRECISION
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is DOUBLE PRECISION
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER 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.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHECON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+ $ WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZHETRS_3, ZLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHECON_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**H) or inv(U*D*U**H).
+*
+ CALL ZHETRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of ZHECON_3
+*
+ END
--- /dev/null
+*> \brief <b> ZHESV_RK computes the solution to system of linear equations A * X = B for SY matrices</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHESV_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhesv_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhesv_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhesv_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHESV_RK computes the solution to a complex system of linear
+*> equations A * X = B, where A is an N-by-N Hermitian matrix
+*> and X and B are N-by-NRHS matrices.
+*>
+*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
+*> to factor A as
+*> A = P*U*D*(U**H)*(P**T), if UPLO = 'U', or
+*> A = P*L*D*(L**H)*(P**T), if UPLO = 'L',
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> ZHETRF_RK is called to compute the factorization of a complex
+*> Hermitian matrix. The factored form of A is then used to solve
+*> the system of equations A * X = B by calling BLAS3 routine ZHETRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order 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,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, if INFO = 0, diagonal of the block diagonal
+*> matrix D and factors U or L as computed by ZHETRF_RK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> For more info see the description of ZHETRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the output computed by the factorization
+*> routine ZHETRF_RK, i.e. the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*>
+*> For more info see the description of ZHETRF_RK routine.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by ZHETRF_RK.
+*>
+*> For more info see the description of ZHETRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension ( MAX(1,LWORK) ).
+*> Work array used in the factorization stage.
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= 1. For best performance
+*> of factorization stage LWORK >= max(1,N*NB), where NB is
+*> the optimal blocksize for ZHETRF_RK.
+*>
+*> If LWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of the WORK
+*> array for factorization stage, 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHESV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZHETRF_RK, ZHETRS_3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHESV_RK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = P*U*D*(U**H)*(P**T) or
+* A = P*U*D*(U**H)*(P**T).
+*
+ CALL ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B with BLAS3 solver, overwriting B with X.
+*
+ CALL ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of ZHESV_RK
+*
+ END
--- /dev/null
+*> \brief \b ZHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETF2_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetf2_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetf2_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetf2_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E ( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHETF2_RK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put further details
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept.,
+*> Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * )
+* ..
+*
+* ======================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE, UPPER
+ INTEGER I, II, IMAX, ITEMP, J, JMAX, K, KK, KP, KSTEP,
+ $ P
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D, D11, D22, R1, DTEMP,
+ $ ROWMAX, TT, SFMIN
+ COMPLEX*16 D12, D21, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+*
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL LSAME, IZAMAX, DLAMCH, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZDSCAL, ZHER, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DCMPLX, DCONJG, DIMAG, MAX, SQRT
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETF2_RK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**H using the upper triangle of A
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 34
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( A( K, K ) )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the leading submatrix A(1:k,1:k)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.GT.1 )
+ $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 14 J = P + 1, K - 1
+ T = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( P, J ) )
+ A( P, J ) = T
+ 14 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = DCONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( K, K ) )
+ A( K, K ) = DBLE( A( P, P ) )
+ A( P, P ) = R1
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA )
+*
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the leading submatrix A(1:k,1:k)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 15 J = KP + 1, KK - 1
+ T = DCONJG( A( J, KK ) )
+ A( J, KK ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 15 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = DCONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( KK, KK ) )
+ A( KK, KK ) = DBLE( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+* (5) Swap row elements
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+*
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K-1, K-1 ) = DBLE( A( K-1, K-1 ) )
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = ONE / DBLE( A( K, K ) )
+ CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL ZDSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = DBLE( A( K, K ) )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZHER( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+* D = |A12|
+ D = DLAPY2( DBLE( A( K-1, K ) ),
+ $ DIMAG( A( K-1, K ) ) )
+ D11 = A( K, K ) / D
+ D22 = A( K-1, K-1 ) / D
+ D12 = A( K-1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WKM1 = TT*( D11*A( J, K-1 )-DCONJG( D12 )*
+ $ A( J, K ) )
+ WK = TT*( D22*A( J, K )-D12*A( J, K-1 ) )
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2)
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*DCONJG( WK ) -
+ $ ( A( I, K-1 ) / D )*DCONJG( WKM1 )
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K-1 ) = WKM1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO )
+*
+ 30 CONTINUE
+*
+ END IF
+*
+* Copy superdiagonal elements of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ E( K ) = A( K-1, K )
+ E( K-1 ) = CZERO
+ A( K-1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 34 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**H using the lower triangle of A
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 64
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( A( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( A( K, K ) )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( A( IMAX, IMAX ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 42
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* For only a 2x2 pivot, interchange rows and columns K and P
+* in the trailing submatrix A(k:n,k:n)
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+* (1) Swap columnar parts
+ IF( P.LT.N )
+ $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 44 J = K + 1, P - 1
+ T = DCONJG( A( J, K ) )
+ A( J, K ) = DCONJG( A( P, J ) )
+ A( P, J ) = T
+ 44 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( P, K ) = DCONJG( A( P, K ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( K, K ) )
+ A( K, K ) = DBLE( A( P, P ) )
+ A( P, P ) = R1
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+*
+ END IF
+*
+* For both 1x1 and 2x2 pivots, interchange rows and
+* columns KK and KP in the trailing submatrix A(k:n,k:n)
+*
+ IF( KP.NE.KK ) THEN
+* (1) Swap columnar parts
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+* (2) Swap and conjugate middle parts
+ DO 45 J = KK + 1, KP - 1
+ T = DCONJG( A( J, KK ) )
+ A( J, KK ) = DCONJG( A( KP, J ) )
+ A( KP, J ) = T
+ 45 CONTINUE
+* (3) Swap and conjugate corner elements at row-col interserction
+ A( KP, KK ) = DCONJG( A( KP, KK ) )
+* (4) Swap diagonal elements at row-col intersection
+ R1 = DBLE( A( KK, KK ) )
+ A( KK, KK ) = DBLE( A( KP, KP ) )
+ A( KP, KP ) = R1
+*
+ IF( KSTEP.EQ.2 ) THEN
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+* (5) Swap row elements
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+*
+ ELSE
+* (*) Make sure that diagonal element of pivot is real
+ A( K, K ) = DBLE( A( K, K ) )
+ IF( KSTEP.EQ.2 )
+ $ A( K+1, K+1 ) = DBLE( A( K+1, K+1 ) )
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of A now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+* Handle division by a small number
+*
+ IF( ABS( DBLE( A( K, K ) ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = ONE / DBLE( A( K, K ) )
+ CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL ZDSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = DBLE( A( K, K ) )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZHER( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+* D = |A21|
+ D = DLAPY2( DBLE( A( K+1, K ) ),
+ $ DIMAG( A( K+1, K ) ) )
+ D11 = DBLE( A( K+1, K+1 ) ) / D
+ D22 = DBLE( A( K, K ) ) / D
+ D21 = A( K+1, K ) / D
+ TT = ONE / ( D11*D22-ONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = TT*( D11*A( J, K )-D21*A( J, K+1 ) )
+ WKP1 = TT*( D22*A( J, K+1 )-DCONJG( D21 )*
+ $ A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) -
+ $ ( A( I, K ) / D )*DCONJG( WK ) -
+ $ ( A( I, K+1 ) / D )*DCONJG( WKP1 )
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D
+ A( J, K+1 ) = WKP1 / D
+* (*) Make sure that diagonal element of pivot is real
+ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), ZERO )
+*
+ 60 CONTINUE
+*
+ END IF
+*
+* Copy subdiagonal elements of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ E( K ) = A( K+1, K )
+ E( K+1 ) = CZERO
+ A( K+1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ 64 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of ZHETF2_RK
+*
+ END
--- /dev/null
+*> \brief \b ZHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHETRF_RK computes the factorization of a complex Hermitian matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned
+*> by ILAENV.
+*>
+*> 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put correct description
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
+ $ NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLAHEF_RK, ZHETF2_RK, ZSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'ZHETRF_RK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRF_RK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'ZHETRF_RK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by ZLAHEF_RK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 15
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL ZLAHEF_RK( UPLO, K, NB, KB, A, LDA, E,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL ZHETF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k-kb+1:k and apply row permutations to the
+* last k+1 colunms k+1:N after that block
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.LT.N ) THEN
+ DO I = K, ( K - KB + 1 ), -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-K, A( I, K+1 ), LDA,
+ $ A( IP, K+1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+* This label is the exit from main loop over K decreasing
+* from N to 1 in steps of KB
+*
+ 15 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by ZLAHEF_RK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 35
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL ZLAHEF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+
+
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL ZHETF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), IINFO )
+ KB = N - K + 1
+*
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO I = K, K + KB - 1
+ IF( IPIV( I ).GT.0 ) THEN
+ IPIV( I ) = IPIV( I ) + K - 1
+ ELSE
+ IPIV( I ) = IPIV( I ) - K + 1
+ END IF
+ END DO
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k:k+kb-1 and apply row permutations to the
+* first k-1 colunms 1:k-1 before that block
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.GT.1 ) THEN
+ DO I = K, ( K + KB - 1 ), 1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( K-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+* This label is the exit from main loop over K increasing
+* from 1 to N in steps of KB
+*
+ 35 CONTINUE
+*
+* End Lower
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of ZHETRF_RK
+*
+ END
--- /dev/null
+*> \brief \b ZHETRI_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRI_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetri_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetri_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetri_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHETRI_3 computes the inverse of a complex Hermitian indefinite
+*> matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> ZHETRI_3 sets the leading dimension of the workspace before calling
+*> ZHETRI_3X that actually computes the inverse. This is the blocked
+*> version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by ZHETRF_RK and ZHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the Hermitian inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZHETRF_RK or ZHETRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (N+NB+1)*(NB+3).
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= (N+NB+1)*(NB+3).
+*>
+*> If LDWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of 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
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZHETRI_3X
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* Determine the block size
+*
+ NB = MAX( 1, ILAENV( 1, 'ZHETRI_3', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = ( N+NB+1 ) * ( NB+3 )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRI_3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ WORK( 1 ) = LWKOPT
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ CALL ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of ZHETRI_3
+*
+ END
--- /dev/null
+*> \brief \b ZHETRI_3X
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRI_3X + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetri_3x.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetri_3x.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetri_3x.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHETRI_3X computes the inverse of a complex Hermitian indefinite
+*> matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by ZHETRF_RK and ZHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the Hermitian inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZHETRF_RK or ZHETRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (N+NB+1,NB+3).
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11
+ DOUBLE PRECISION AK, AKP1, T
+ COMPLEX*16 AKKP1, D, U01_I_J, U01_IP1_J, U11_I_J,
+ $ U11_IP1_J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMM, ZHESWAPR, ZTRTRI, ZTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DCONJG, DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+*
+* Quick return if possible
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRI_3X', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Workspace got Non-diag elements of D
+*
+ DO K = 1, N
+ WORK( K, 1 ) = E( K )
+ END DO
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+ INFO = 0
+*
+* Splitting Workspace
+* U01 is a block ( N, NB+1 )
+* The first element of U01 is in WORK( 1, 1 )
+* U11 is a block ( NB+1, NB+1 )
+* The first element of U11 is in WORK( N+1, 1 )
+*
+ U11 = N
+*
+* INVD is a block ( N, 2 )
+* The first element of INVD is in WORK( 1, INVD )
+*
+ INVD = NB + 2
+
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* invA = P * inv(U**H) * inv(D) * inv(U) * P**T.
+*
+ CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(U)
+*
+ K = 1
+ DO WHILE( K.LE.N )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / DBLE( A( K, K ) )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = ABS( WORK( K+1, 1 ) )
+ AK = DBLE( A( K, K ) ) / T
+ AKP1 = DBLE( A( K+1, K+1 ) ) / T
+ AKKP1 = WORK( K+1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K, INVD ) = AKP1 / D
+ WORK( K+1, INVD+1 ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K+1, INVD ) = DCONJG( WORK( K, INVD+1 ) )
+ K = K + 1
+ END IF
+ K = K + 1
+ END DO
+*
+* inv(U**H) = (inv(U))**H
+*
+* inv(U**H) * inv(D) * inv(U)
+*
+ CUT = N
+ DO WHILE( CUT.GT.0 )
+ NNB = NB
+ IF( CUT.LE.NNB ) THEN
+ NNB = CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT+1-NNB, CUT
+ IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+
+ CUT = CUT - NNB
+*
+* U01 Block
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ WORK( I, J ) = A( I, CUT+J )
+ END DO
+ END DO
+*
+* U11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I ) = CONE
+ DO J = 1, I-1
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD * U01
+*
+ I = 1
+ DO WHILE( I.LE.CUT )
+ IF( IPIV( I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( I, INVD ) * WORK( I, J )
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK( I, J )
+ U01_IP1_J = WORK( I+1, J )
+ WORK( I, J ) = WORK( I, INVD ) * U01_I_J
+ $ + WORK( I, INVD+1 ) * U01_IP1_J
+ WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J
+ $ + WORK( I+1, INVD+1 ) * U01_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* invD1 * U11
+*
+ I = 1
+ DO WHILE ( I.LE.NNB )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = I, NNB
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ END DO
+ ELSE
+ DO J = I, NNB
+ U11_I_J = WORK(U11+I,J)
+ U11_IP1_J = WORK(U11+I+1,J)
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J)
+ WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J
+ $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* U11**H * invD1 * U11 -> U11
+*
+ CALL ZTRMM( 'L', 'U', 'C', 'U', NNB, NNB,
+ $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+* U01**H * invD * U01 -> A( CUT+I, CUT+J )
+*
+ CALL ZGEMM( 'C', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ),
+ $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1),
+ $ N+NB+1 )
+
+*
+* U11 = U11**H * invD1 * U11 + U01**H * invD * U01
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J)
+ END DO
+ END DO
+*
+* U01 = U00**H * invD0 * U01
+*
+ CALL ZTRMM( 'L', UPLO, 'C', 'U', CUT, NNB,
+ $ CONE, A, LDA, WORK, N+NB+1 )
+
+*
+* Update U01
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ A( I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+* Next Block
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(U**H) * inv(D) * inv(U) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Upper case.
+*
+* ( We can use a loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = 1, N
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* inv A = P * inv(L**H) * inv(D) * inv(L) * P**T.
+*
+ CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(L)
+*
+ K = N
+ DO WHILE ( K .GE. 1 )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = ONE / DBLE( A( K, K ) )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = ABS( WORK( K-1, 1 ) )
+ AK = DBLE( A( K-1, K-1 ) ) / T
+ AKP1 = DBLE( A( K, K ) ) / T
+ AKKP1 = WORK( K-1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K-1, INVD ) = AKP1 / D
+ WORK( K, INVD ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K-1, INVD+1 ) = DCONJG( WORK( K, INVD+1 ) )
+ K = K - 1
+ END IF
+ K = K - 1
+ END DO
+*
+* inv(L**H) = (inv(L))**H
+*
+* inv(L**H) * inv(D) * inv(L)
+*
+ CUT = 0
+ DO WHILE( CUT.LT.N )
+ NNB = NB
+ IF( (CUT + NNB).GT.N ) THEN
+ NNB = N - CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT + 1, CUT+NNB
+ IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+*
+* L21 Block
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ WORK( I, J ) = A( CUT+NNB+I, CUT+J )
+ END DO
+ END DO
+*
+* L11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I) = CONE
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = 1, I-1
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD*L21
+*
+ I = N-CUT-NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+NNB+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J)
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK(I,J)
+ U01_IP1_J = WORK(I-1,J)
+ WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+
+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J
+ WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+
+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* invD1*L11
+*
+ I = NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J)
+ END DO
+
+ ELSE
+ DO J = 1, NNB
+ U11_I_J = WORK( U11+I, J )
+ U11_IP1_J = WORK( U11+I-1, J )
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * U11_IP1_J
+ WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J
+ $ + WORK(CUT+I-1,INVD) * U11_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* L11**H * invD1 * L11 -> L11
+*
+ CALL ZTRMM( 'L', UPLO, 'C', 'U', NNB, NNB, CONE,
+ $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+ IF( (CUT+NNB).LT.N ) THEN
+*
+* L21**H * invD2*L21 -> A( CUT+I, CUT+J )
+*
+ CALL ZGEMM( 'C', 'N', NNB, NNB, N-NNB-CUT, CONE,
+ $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1,
+ $ CZERO, WORK( U11+1, 1 ), N+NB+1 )
+
+*
+* L11 = L11**H * invD1 * L11 + U01**H * invD * U01
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J)
+ END DO
+ END DO
+*
+* L01 = L22**H * invD2 * L21
+*
+ CALL ZTRMM( 'L', UPLO, 'C', 'U', N-NNB-CUT, NNB, CONE,
+ $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK,
+ $ N+NB+1 )
+*
+* Update L21
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ A( CUT+NNB+I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+ ELSE
+*
+* L11 = L11**H * invD1 * L11
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+ END IF
+*
+* Next Block
+*
+ CUT = CUT + NNB
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(L**H) * inv(D) * inv(L) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Lower case.
+*
+* ( We can use a loop over IPIV with increment -1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = N, 1, -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL ZHESWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of ZHETRI_3X
+*
+ END
--- /dev/null
+*> \brief \b ZHETRS_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZHETRS_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrs_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrs_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrs_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZHETRS_3 solves a system of linear equations A * X = B with a complex
+*> Hermitian matrix A using the factorization computed
+*> by ZHETRF_RK or ZHETRF_BK:
+*>
+*> A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**H (or L**H) is the conjugate of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is Hermitian and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This algorithm is using Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**H)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**H)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order 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] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by ZHETRF_RK and ZHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZHETRF_RK or ZHETRF_BK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,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.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = ( 1.0D+0,0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J, K, KP
+ DOUBLE PRECISION S
+ COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZDSCAL, ZSWAP, ZTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DCONJG, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZHETRS_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* Solve A*X = B, where A = U*D*U**H.
+*
+* P**T * B
+*
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
+*
+ CALL ZTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (U \P**T * B) ]
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+ S = DBLE( ONE ) / DBLE( A( I, I ) )
+ CALL ZDSCAL( NRHS, S, B( I, 1 ), LDB )
+ ELSE IF ( I.GT.1 ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I-1, I-1 ) / AKM1K
+ AK = A( I, I ) / DCONJG( AKM1K )
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I-1, J ) / AKM1K
+ BK = B( I, J ) / DCONJG( AKM1K )
+ B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ]
+*
+ CALL ZTRSM( 'L', 'U', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (U**H \ (D \ (U \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* Solve A*X = B, where A = L*D*L**H.
+*
+* P**T * B
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
+*
+ CALL ZTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (L \P**T * B) ]
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+ S = DBLE( ONE ) / DBLE( A( I, I ) )
+ CALL ZDSCAL( NRHS, S, B( I, 1 ), LDB )
+ ELSE IF( I.LT.N ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I, I ) / DCONJG( AKM1K )
+ AK = A( I+1, I+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I, J ) / DCONJG( AKM1K )
+ BK = B( I+1, J ) / AKM1K
+ B( I, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ]
+*
+ CALL ZTRSM('L', 'L', 'C', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (L**H \ (D \ (L \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* END Lower
+*
+ END IF
+*
+ RETURN
+*
+* End of ZHETRS_3
+*
+ END
+++ /dev/null
-*> \brief \b ZHETRS_AASEN
-*
-* =========== DOCUMENTATION ===========
-*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
-*
-*> \htmlonly
-*> Download ZHETRS_AASEN + dependencies
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zhetrs_aasen.f">
-*> [TGZ]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zhetrs_aasen.f">
-*> [ZIP]</a>
-*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zhetrs_aasen.f">
-*> [TXT]</a>
-*> \endhtmlonly
-*
-* Definition:
-* ===========
-*
-* SUBROUTINE ZHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
-* WORK, LWORK, INFO )
-*
-* .. Scalar Arguments ..
-* CHARACTER UPLO
-* INTEGER N, NRHS, LDA, LDB, LWORK, INFO
-* ..
-* .. Array Arguments ..
-* INTEGER IPIV( * )
-* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
-* ..
-*
-*
-*> \par Purpose:
-* =============
-*>
-*> \verbatim
-*>
-*> ZHETRS_AASEN solves a system of linear equations A*X = B with a real
-*> hermitian matrix A using the factorization A = U*T*U**T or
-*> A = L*T*L**T computed by ZHETRF_AASEN.
-*> \endverbatim
-*
-* Arguments:
-* ==========
-*
-*> \param[in] UPLO
-*> \verbatim
-*> UPLO is CHARACTER*1
-*> Specifies whether the details of the factorization are stored
-*> as an upper or lower triangular matrix.
-*> = 'U': Upper triangular, form is A = U*T*U**T;
-*> = 'L': Lower triangular, form is A = L*T*L**T.
-*> \endverbatim
-*>
-*> \param[in] N
-*> \verbatim
-*> N is INTEGER
-*> The order 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,out] A
-*> \verbatim
-*> A is COMPLEX*16 array, dimension (LDA,N)
-*> Details of factors computed by ZHETRF_AASEN.
-*> \endverbatim
-*>
-*> \param[in] LDA
-*> \verbatim
-*> LDA is INTEGER
-*> The leading dimension of the array A. LDA >= max(1,N).
-*> \endverbatim
-*>
-*> \param[in] IPIV
-*> \verbatim
-*> IPIV is INTEGER array, dimension (N)
-*> Details of the interchanges as computed by ZHETRF_AASEN.
-*> \endverbatim
-*>
-*> \param[in,out] B
-*> \verbatim
-*> B is COMPLEX*16 array, dimension (LDB,NRHS)
-*> On entry, the right hand side matrix B.
-*> On exit, the solution matrix X.
-*> \endverbatim
-*>
-*> \param[in] LDB
-*> \verbatim
-*> LDB is INTEGER
-*> The leading dimension of the array B. LDB >= max(1,N).
-*> \endverbatim
-*>
-*> \param[in] WORK
-*> \verbatim
-*> WORK is DOUBLE array, dimension (MAX(1,LWORK))
-*> \endverbatim
-*>
-*> \param[in] LWORK
-*> \verbatim
-*> LWORK is INTEGER, LWORK >= 3*N-2.
-*>
-*> \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.
-*
-*> \date November 2016
-*
-*> \ingroup complex16SYcomputational
-*
-* @precisions fortran z -> c
-*
-* =====================================================================
- SUBROUTINE ZHETRS_AASEN( UPLO, N, NRHS, A, LDA, IPIV, B, LDB,
- $ WORK, LWORK, INFO )
-*
-* -- LAPACK computational routine (version 3.4.0) --
-* -- LAPACK is a software package provided by Univ. of Tennessee, --
-* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2016
-*
- IMPLICIT NONE
-*
-* .. Scalar Arguments ..
- CHARACTER UPLO
- INTEGER N, NRHS, LDA, LDB, LWORK, INFO
-* ..
-* .. Array Arguments ..
- INTEGER IPIV( * )
- COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * )
-* ..
-*
-* =====================================================================
-*
- COMPLEX*16 ONE
- PARAMETER ( ONE = 1.0D+0 )
-* ..
-* .. Local Scalars ..
- LOGICAL UPPER
- INTEGER K, KP
-* ..
-* .. External Functions ..
- LOGICAL LSAME
- EXTERNAL LSAME
-* ..
-* .. External Subroutines ..
- EXTERNAL ZGTSV, ZSWAP, ZTRSM, XERBLA
-* ..
-* .. Intrinsic Functions ..
- INTRINSIC MAX
-* ..
-* .. Executable Statements ..
-*
- INFO = 0
- UPPER = LSAME( UPLO, 'U' )
- IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
- INFO = -1
- ELSE IF( N.LT.0 ) THEN
- INFO = -2
- ELSE IF( NRHS.LT.0 ) THEN
- INFO = -3
- ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
- INFO = -5
- ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
- INFO = -8
- ELSE IF( LWORK.LT.(3*N-2) ) THEN
- INFO = -10
- END IF
- IF( INFO.NE.0 ) THEN
- CALL XERBLA( 'ZHETRS_AASEN', -INFO )
- RETURN
- END IF
-*
-* Quick return if possible
-*
- IF( N.EQ.0 .OR. NRHS.EQ.0 )
- $ RETURN
-*
- IF( UPPER ) THEN
-*
-* Solve A*X = B, where A = U*T*U**T.
-*
-* Pivot, P**T * B
-*
- DO K = 1, N
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- END DO
-*
-* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
-*
- CALL ZTRSM('L', 'U', 'C', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
- $ B( 2, 1 ), LDB)
-*
-* Compute T \ B -> B [ T \ (U \P**T * B) ]
-*
- CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
- IF( N.GT.1 ) THEN
- CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 2*N ), 1)
- CALL ZLACPY( 'F', 1, N-1, A( 1, 2 ), LDA+1, WORK( 1 ), 1)
- CALL ZLACGV( N-1, WORK( 1 ), 1 )
- END IF
- CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
- $ INFO)
-*
-* Compute (U**T \ B) -> B [ U**T \ (T \ (U \P**T * B) ) ]
-*
- CALL ZTRSM( 'L', 'U', 'N', 'U', N-1, NRHS, ONE, A( 1, 2 ), LDA,
- $ B(2, 1), LDB)
-*
-* Pivot, P * B [ P * (U**T \ (T \ (U \P**T * B) )) ]
-*
- DO K = N, 1, -1
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- END DO
-*
- ELSE
-*
-* Solve A*X = B, where A = L*T*L**T.
-*
-* Pivot, P**T * B
-*
- DO K = 1, N
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- END DO
-*
-* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
-*
- CALL ZTRSM( 'L', 'L', 'N', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
- $ B(2, 1), LDB)
-*
-* Compute T \ B -> B [ T \ (L \P**T * B) ]
-*
- CALL ZLACPY( 'F', 1, N, A(1, 1), LDA+1, WORK(N), 1)
- IF( N.GT.1 ) THEN
- CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 1 ), 1)
- CALL ZLACPY( 'F', 1, N-1, A( 2, 1 ), LDA+1, WORK( 2*N ), 1)
- CALL ZLACGV( N-1, WORK( 2*N ), 1 )
- END IF
- CALL ZGTSV(N, NRHS, WORK(1), WORK(N), WORK(2*N), B, LDB,
- $ INFO)
-*
-* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ]
-*
- CALL ZTRSM( 'L', 'L', 'C', 'U', N-1, NRHS, ONE, A( 2, 1 ), LDA,
- $ B( 2, 1 ), LDB)
-*
-* Pivot, P * B [ P * (L**T \ (T \ (L \P**T * B) )) ]
-*
- DO K = N, 1, -1
- KP = IPIV( K )
- IF( KP.NE.K )
- $ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
- END DO
-*
- END IF
-*
- RETURN
-*
-* End of ZHETRS_AASEN
-*
- END
--- /dev/null
+*> \brief \b ZLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLAHEF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlahef_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlahef_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlahef_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZLAHEF_RK computes a partial factorization of a complex Hermitian
+*> matrix A using the bounded Bunch-Kaufman (rook) diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**H U22**H )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L',
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> ZLAHEF_RK is an auxiliary routine called by ZHETRF_RK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the Hermitian matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,N-KB+1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,N-KB+1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,N-KB+1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,1:KB).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16HEcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), W( LDW, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ COMPLEX*16 CONE
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, II, J, JB, JJ, JMAX, K, KK, KKW,
+ $ KP, KSTEP, KW, P
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, DTEMP, R1, ROWMAX, T,
+ $ SFMIN
+ COMPLEX*16 D11, D21, D22, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IZAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZCOPY, ZDSCAL, ZGEMM, ZGEMV, ZLACGV, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DCONJG, DIMAG, MAX, MIN, SQRT
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11 (note that conjg(W) is actually stored)
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ IF( K.GT.1 )
+ $ CALL ZCOPY( K-1, A( 1, K ), 1, W( 1, KW ), 1 )
+ W( K, KW ) = DBLE( A( K, K ) )
+ IF( K.LT.N ) THEN
+ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ), LDA,
+ $ W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+ W( K, KW ) = DBLE( W( K, KW ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( W( K, KW ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( W( K, KW ) )
+ IF( K.GT.1 )
+ $ CALL ZCOPY( K-1, W( 1, KW ), 1, A( 1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+* Lop until pivot found
+*
+ DONE = .FALSE.
+*
+ 12 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ IF( IMAX.GT.1 )
+ $ CALL ZCOPY( IMAX-1, A( 1, IMAX ), 1, W( 1, KW-1 ),
+ $ 1 )
+ W( IMAX, KW-1 ) = DBLE( A( IMAX, IMAX ) )
+*
+ CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+ CALL ZLACGV( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N ) THEN
+ CALL ZGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+ W( IMAX, KW-1 ) = DBLE( W( IMAX, KW-1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ DTEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( W( IMAX,KW-1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+*
+* END pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 12
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+* Interchange rows and columns P and K.
+* Updated column P is already stored in column KW of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K-1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = DBLE( A( K, K ) )
+ CALL ZCOPY( K-1-P, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ CALL ZLACGV( K-1-P, A( P, P+1 ), LDA )
+ IF( P.GT.1 )
+ $ CALL ZCOPY( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in the last K+1 to N columns of A
+* (columns K and K-1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ),
+ $ LDA )
+ CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ),
+ $ LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KKW of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K-1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = DBLE( A( KK, KK ) )
+ CALL ZCOPY( KK-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL ZLACGV( KK-1-KP, A( KP, KP+1 ), LDA )
+ IF( KP.GT.1 )
+ $ CALL ZCOPY( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last K+1 to N columns of A
+* (columns K (or K and K-1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in last KKW to NB columns of W.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+ CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column kw of W now holds
+*
+* W(kw) = U(k)*D(k),
+*
+* where U(k) is the k-th column of U
+*
+* (1) Store subdiag. elements of column U(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element U(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,kw)
+* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = DBLE( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL ZDSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+ DO 14 II = 1, K-1
+ A( II, K ) = A( II, K ) / T
+ 14 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(kw)
+*
+ CALL ZLACGV( K-1, W( 1, KW ), 1 )
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold
+*
+* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2
+* block D(k-1:k,k-1:k) in columns k-1 and k of A.
+* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT
+* block and not stored)
+* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw)
+* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) =
+* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) )
+*
+ IF( K.GT.2 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K-1, KW )
+ D11 = W( K, KW ) / DCONJG( D21 )
+ D22 = W( K-1, KW-1 ) / D21
+ T = ONE / ( DBLE( D11*D22 )-ONE )
+*
+* Update elements in columns A(k-1) and A(k) as
+* dot products of rows of ( W(kw-1) W(kw) ) and columns
+* of D**(-1)
+*
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( ( D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D21 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ DCONJG( D21 ) )
+ 20 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy superdiagonal element of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = CZERO
+ A( K, K ) = W( K, KW )
+ E( K ) = W( K-1, KW )
+ E( K-1 ) = CZERO
+*
+* (2) Conjugate columns W(kw) and W(kw-1)
+*
+ CALL ZLACGV( K-1, W( 1, KW ), 1 )
+ CALL ZLACGV( K-2, W( 1, KW-1 ), 1 )
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**H = A11 - U12*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB, N-K,
+ $ -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ), LDW,
+ $ CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22 (note that conjg(W) is actually stored)
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update column K of W
+*
+ W( K, K ) = DBLE( A( K, K ) )
+ IF( K.LT.N )
+ $ CALL ZCOPY( N-K, A( K+1, K ), 1, W( K+1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+ W( K, K ) = DBLE( W( K, K ) )
+ END IF
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( DBLE( W( K, K ) ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ A( K, K ) = DBLE( W( K, K ) )
+ IF( K.LT.N )
+ $ CALL ZCOPY( N-K, W( K+1, K ), 1, A( K+1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* BEGIN pivot search
+*
+* Case(1)
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* BEGIN pivot search loop body
+*
+*
+* Copy column IMAX to column k+1 of W and update it
+*
+ CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL ZLACGV( IMAX-K, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = DBLE( A( IMAX, IMAX ) )
+*
+ IF( IMAX.LT.N )
+ $ CALL ZCOPY( N-IMAX, A( IMAX+1, IMAX ), 1,
+ $ W( IMAX+1, K+1 ), 1 )
+*
+ IF( K.GT.1 ) THEN
+ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+ W( IMAX, K+1 ) = DBLE( W( IMAX, K+1 ) )
+ END IF
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ DTEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Case(2)
+* Equivalent to testing for
+* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABS( DBLE( W( IMAX,K+1 ) ) )
+ $ .LT.ALPHA*ROWMAX ) ) THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Case(3)
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+*
+* Case(4)
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+*
+* End pivot search loop body
+*
+ IF( .NOT.DONE ) GOTO 72
+*
+ END IF
+*
+* END pivot search
+*
+* ============================================================
+*
+* KK is the column of A where pivoting step stopped
+*
+ KK = K + KSTEP - 1
+*
+* Interchange rows and columns P and K (only for 2-by-2 pivot).
+* Updated column P is already stored in column K of W.
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column KK-1 to column P of submatrix A
+* at step K. No need to copy element into columns
+* K and K+1 of A for 2-by-2 pivot, since these columns
+* will be later overwritten.
+*
+ A( P, P ) = DBLE( A( K, K ) )
+ CALL ZCOPY( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ CALL ZLACGV( P-K-1, A( P, K+1 ), LDA )
+ IF( P.LT.N )
+ $ CALL ZCOPY( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+*
+* Interchange rows K and P in first K-1 columns of A
+* (columns K and K+1 of A for 2-by-2 pivot will be
+* later overwritten). Interchange rows K and P
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Interchange rows and columns KP and KK.
+* Updated column KP is already stored in column KK of W.
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP of submatrix A
+* at step K. No need to copy element into column K
+* (or K and K+1 for 2-by-2 pivot) of A, since these columns
+* will be later overwritten.
+*
+ A( KP, KP ) = DBLE( A( KK, KK ) )
+ CALL ZCOPY( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ CALL ZLACGV( KP-KK-1, A( KP, KK+1 ), LDA )
+ IF( KP.LT.N )
+ $ CALL ZCOPY( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+*
+* Interchange rows KK and KP in first K-1 columns of A
+* (column K (or K and K+1 for 2-by-2 pivot) of A will be
+* later overwritten). Interchange rows KK and KP
+* in first KK columns of W.
+*
+ IF( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k),
+*
+* where L(k) is the k-th column of L
+*
+* (1) Store subdiag. elements of column L(k)
+* and 1-by-1 block D(k) in column k of A.
+* (NOTE: Diagonal element L(k,k) is a UNIT element
+* and not stored)
+* A(k,k) := D(k,k) = W(k,k)
+* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k)
+*
+* (NOTE: No need to use for Hermitian matrix
+* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal
+* element D(k,k) from W (potentially saves only one load))
+ CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+*
+* (NOTE: No need to check if A(k,k) is NOT ZERO,
+* since that was ensured earlier in pivot search:
+* case A(k,k) = 0 falls into 2x2 pivot case(3))
+*
+* Handle division by a small number
+*
+ T = DBLE( A( K, K ) )
+ IF( ABS( T ).GE.SFMIN ) THEN
+ R1 = ONE / T
+ CALL ZDSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / T
+ 74 CONTINUE
+ END IF
+*
+* (2) Conjugate column W(k)
+*
+ CALL ZLACGV( N-K, W( K+1, K ), 1 )
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2
+* block D(k:k+1,k:k+1) in columns k and k+1 of A.
+* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT
+* block and not stored.
+* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1)
+* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) =
+* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) )
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Factor out the columns of the inverse of 2-by-2 pivot
+* block D, so that each column contains 1, to reduce the
+* number of FLOPS when we multiply panel
+* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1).
+*
+* D**(-1) = ( d11 cj(d21) )**(-1) =
+* ( d21 d22 )
+*
+* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) =
+* ( (-d21) ( d11 ) )
+*
+* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) *
+*
+* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) =
+* ( ( -1 ) ( d11/conj(d21) ) )
+*
+* = 1/(|d21|**2) * 1/(D22*D11-1) *
+*
+* * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) =
+* ( ( -1 ) ( D22 ) )
+*
+* Handle division by a small number. (NOTE: order of
+* operations is important)
+*
+* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) )
+* ( (( -1 ) ) (( D22 ) ) ),
+*
+* where D11 = d22/d21,
+* D22 = d11/conj(d21),
+* D21 = d21,
+* T = 1/(D22*D11-1).
+*
+* (NOTE: No need to check for division by ZERO,
+* since that was ensured earlier in pivot search:
+* (a) d21 != 0 in 2x2 pivot case(4),
+* since |d21| should be larger than |d11| and |d22|;
+* (b) (D22*D11 - 1) != 0, since from (a),
+* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.)
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / DCONJG( D21 )
+ T = ONE / ( DBLE( D11*D22 )-ONE )
+*
+* Update elements in columns A(k) and A(k+1) as
+* dot products of rows of ( W(k) W(k+1) ) and columns
+* of D**(-1)
+*
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ DCONJG( D21 ) )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy subdiagonal element of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = CZERO
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ E( K ) = W( K+1, K )
+ E( K+1 ) = CZERO
+*
+* (2) Conjugate columns W(k) and W(k+1)
+*
+ CALL ZLACGV( N-K, W( K+1, K ), 1 )
+ CALL ZLACGV( N-K-1, W( K+2, K+1 ), 1 )
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**H = A22 - L21*W**H
+*
+* computing blocks of NB columns at a time (note that conjg(W) is
+* actually stored)
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ A( JJ, JJ ) = DBLE( A( JJ, JJ ) )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of ZLAHEF_RK
+*
+ END
--- /dev/null
+*> \brief \b ZLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bounded Bunch-Kaufman (rook) diagonal pivoting method.
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZLASYF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlasyf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlasyf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlasyf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZLASYF_RK computes a partial factorization of a complex symmetric
+*> matrix A using the bounded Bunch-Kaufman (rook) diagonal
+*> pivoting method. The partial factorization has the form:
+*>
+*> A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+*> ( 0 U22 ) ( 0 D ) ( U12**T U22**T )
+*>
+*> A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L',
+*> ( L21 I ) ( 0 A22 ) ( 0 I )
+*>
+*> where the order of D is at most NB. The actual order is returned in
+*> the argument KB, and is either NB or NB-1, or N if N <= NB.
+*>
+*> ZLASYF_RK is an auxiliary routine called by ZSYTRF_RK. It uses
+*> blocked code (calling Level 3 BLAS) to update the submatrix
+*> A11 (if UPLO = 'U') or A22 (if UPLO = 'L').
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> The maximum number of columns of the matrix A that should be
+*> factored. NB should be at least 2 to allow for 2-by-2 pivot
+*> blocks.
+*> \endverbatim
+*>
+*> \param[out] KB
+*> \verbatim
+*> KB is INTEGER
+*> The number of columns of A that were actually factored.
+*> KB is either NB-1 or NB, or N if N <= NB.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,N-KB+1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,N-KB+1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,N-KB+1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the submatrix A(1:N,1:KB).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the submatrix A(1:N,1:KB).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b) is always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] W
+*> \verbatim
+*> W is COMPLEX*16 array, dimension (LDW,NB)
+*> \endverbatim
+*>
+*> \param[in] LDW
+*> \verbatim
+*> LDW is INTEGER
+*> The leading dimension of the array W. LDW >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER IMAX, ITEMP, J, JB, JJ, JMAX, K, KK, KW, KKW,
+ $ KP, KSTEP, P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, SFMIN, DTEMP
+ COMPLEX*16 D11, D12, D21, D22, R1, T, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IZAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZCOPY, ZGEMM, ZGEMV, ZSCAL, ZSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, DIMAG, MAX, MIN, SQRT
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* KW is the column of W which corresponds to column K of A
+*
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL ZCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL ZGEMV( 'No transpose', K, N-K, -CONE, A( 1, K+1 ),
+ $ LDA, W( K, KW+1 ), LDW, CONE, W( 1, KW ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = CABS1( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL ZCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL ZCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+*
+ IF( K.LT.N )
+ $ CALL ZGEMV( 'No transpose', K, N-K, -CONE,
+ $ A( 1, K+1 ), LDA, W( IMAX, KW+1 ), LDW,
+ $ CONE, W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, W( IMAX+1, KW-1 ),
+ $ 1 )
+ ROWMAX = CABS1( W( JMAX, KW-1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ DTEMP = CABS1( W( ITEMP, KW-1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.(CABS1( W( IMAX, KW-1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K-1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K - KSTEP + 1
+*
+* KKW is the column of W which corresponds to column KK of A
+*
+ KKW = NB + KK - N
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL ZCOPY( K-P, A( P+1, K ), 1, A( P, P+1 ), LDA )
+ CALL ZCOPY( P, A( 1, K ), 1, A( 1, P ), 1 )
+*
+* Interchange rows K and P in last N-K+1 columns of A
+* and last N-K+2 columns of W
+*
+ CALL ZSWAP( N-K+1, A( K, K ), LDA, A( P, K ), LDA )
+ CALL ZSWAP( N-KK+1, W( K, KKW ), LDW, W( P, KKW ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL ZCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL ZCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last N-KK+1 columns
+* of A and W
+*
+ CALL ZSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL ZSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL ZCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ IF( K.GT.1 ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL ZSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 14 II = 1, K - 1
+ A( II, K ) = A( II, K ) / A( K, K )
+ 14 CONTINUE
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D12 = W( K-1, KW )
+ D11 = W( K, KW ) / D12
+ D22 = W( K-1, KW-1 ) / D12
+ T = CONE / ( D11*D22-CONE )
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = T*( (D11*W( J, KW-1 )-W( J, KW ) ) /
+ $ D12 )
+ A( J, K ) = T*( ( D22*W( J, KW )-W( J, KW-1 ) ) /
+ $ D12 )
+ 20 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy superdiagonal element of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = CZERO
+ A( K, K ) = W( K, KW )
+ E( K ) = W( K-1, KW )
+ E( K-1 ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12**T = A11 - U12*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL ZGEMV( 'No transpose', JJ-J+1, N-K, -CONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, CONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ IF( J.GE.2 )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', J-1, JB,
+ $ N-K, -CONE, A( 1, K+1 ), LDA, W( J, KW+1 ),
+ $ LDW, CONE, A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+ KSTEP = 1
+ P = K
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL ZCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ IF( K.GT.1 )
+ $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE, A( K, 1 ),
+ $ LDA, W( K, 1 ), LDW, CONE, W( K, K ), 1 )
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = CABS1( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* ============================================================
+*
+* Test for interchange
+*
+* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 72 CONTINUE
+*
+* Begin pivot search loop body
+*
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL ZCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1)
+ CALL ZCOPY( N-IMAX+1, A( IMAX, IMAX ), 1,
+ $ W( IMAX, K+1 ), 1 )
+ IF( K.GT.1 )
+ $ CALL ZGEMV( 'No transpose', N-K+1, K-1, -CONE,
+ $ A( K, 1 ), LDA, W( IMAX, 1 ), LDW,
+ $ CONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = CABS1( W( JMAX, K+1 ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, W( IMAX+1, K+1 ), 1)
+ DTEMP = CABS1( W( ITEMP, K+1 ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for
+* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX
+* (used to handle NaN and Inf)
+*
+ IF( .NOT.( CABS1( W( IMAX, K+1 ) ).LT.ALPHA*ROWMAX ) )
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX.EQ.COLMAX,
+* (used to handle NaN and Inf)
+*
+ ELSE IF( ( P.EQ.JMAX ) .OR. ( ROWMAX.LE.COLMAX ) )
+ $ THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot not found: set params and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+*
+* Copy updated JMAXth (next IMAXth) column to Kth of W
+*
+ CALL ZCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+*
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 72
+*
+ END IF
+*
+* ============================================================
+*
+ KK = K + KSTEP - 1
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Copy non-updated column K to column P
+*
+ CALL ZCOPY( P-K, A( K, K ), 1, A( P, K ), LDA )
+ CALL ZCOPY( N-P+1, A( P, K ), 1, A( P, P ), 1 )
+*
+* Interchange rows K and P in first K columns of A
+* and first K+1 columns of W
+*
+ CALL ZSWAP( K, A( K, 1 ), LDA, A( P, 1 ), LDA )
+ CALL ZSWAP( KK, W( K, 1 ), LDW, W( P, 1 ), LDW )
+ END IF
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL ZCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL ZCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL ZSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL ZSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL ZCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+ R1 = CONE / A( K, K )
+ CALL ZSCAL( N-K, R1, A( K+1, K ), 1 )
+ ELSE IF( A( K, K ).NE.CZERO ) THEN
+ DO 74 II = K + 1, N
+ A( II, K ) = A( II, K ) / A( K, K )
+ 74 CONTINUE
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+ DO 80 J = K + 2, N
+ A( J, K ) = T*( ( D11*W( J, K )-W( J, K+1 ) ) /
+ $ D21 )
+ A( J, K+1 ) = T*( ( D22*W( J, K+1 )-W( J, K ) ) /
+ $ D21 )
+ 80 CONTINUE
+ END IF
+*
+* Copy diagonal elements of D(K) to A,
+* copy subdiagonal element of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = CZERO
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ E( K ) = W( K+1, K )
+ E( K+1 ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21**T = A22 - L21*W**T
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL ZGEMV( 'No transpose', J+JB-JJ, K-1, -CONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, CONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL ZGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -CONE, A( J+JB, 1 ), LDA, W( J, 1 ),
+ $ LDW, CONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+*
+ RETURN
+*
+* End of ZLASYF_RK
+*
+ END
--- /dev/null
+*> \brief \b ZSYCON_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYCON_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsycon_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsycon_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsycon_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+* WORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * ), IWORK( * )
+* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYCON_3 estimates the reciprocal of the condition number (in the
+*> 1-norm) of a complex symmetric matrix A using the factorization
+*> computed by ZSYTRF_RK or ZSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
+*> condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*> This routine uses BLAS3 solver ZSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by ZSYTRF_RK and ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_RK or ZSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in] ANORM
+*> \verbatim
+*> ANORM is DOUBLE PRECISION
+*> The 1-norm of the original matrix A.
+*> \endverbatim
+*>
+*> \param[out] RCOND
+*> \verbatim
+*> RCOND is DOUBLE PRECISION
+*> The reciprocal of the condition number of the matrix A,
+*> computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+*> estimate of the 1-norm of inv(A) computed in this routine.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (2*N)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER 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.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND,
+ $ WORK, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLACN2, ZSYTRS_3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYCON_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.CZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL ZLACN2( N, WORK( N+1 ), WORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L**T) or inv(U*D*U**T).
+*
+ CALL ZSYTRS_3( UPLO, N, 1, A, LDA, E, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of ZSYCON_3
+*
+ END
--- /dev/null
+*> \brief \b ZSYCONVF
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYCONVF + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsyconvf.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsyconvf.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsyconvf.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYCONVF( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> ZSYCONVF converts the factorization output format used in
+*> ZSYTRF provided on entry in parameter A into the factorization
+*> output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored
+*> on exit in parameters A and E. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in ZSYTRF into
+*> the format used in ZSYTRF_RK (or ZSYTRF_BK).
+*>
+*> If parameter WAY = 'R':
+*> ZSYCONVF performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in ZSYTRF_RK
+*> (or ZSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in ZSYTRF that is stored
+*> on exit in parameter A. It also coverts in place details of
+*> the intechanges stored in IPIV from the format used in ZSYTRF_RK
+*> (or ZSYTRF_BK) into the format used in ZSYTRF.
+*>
+*> ZSYCONVF can also convert in Hermitian matrix case, i.e. between
+*> formats used in ZHETRF and ZHETRF_RK (or ZHETRF_BK).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> ZSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> ZSYTRF_RK or ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> ZSYTRF_RK or ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> ZSYTRF:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in,out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in ZSYTRF.
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in ZSYTRF_RK
+*> ( or ZSYTRF_BK).
+*>
+*> 1) If WAY ='R':
+*> On entry, details of the interchanges and the block
+*> structure of D in the format used in ZSYTRF_RK
+*> ( or ZSYTRF_BK).
+*> On exit, details of the interchanges and the block
+*> structure of D in the format used in ZSYTRF.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE ZSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL ZSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYCONVF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL ZSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i) in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.(I-1) ) THEN
+ CALL ZSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i-1 and IPIV(i-1),
+* so this should be recorded in two consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I-1 )
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where k increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL ZSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is no interchnge of rows i and and IPIV(i),
+* so this should be reflected in IPIV format for
+* *SYTRF_RK ( or *SYTRF_BK)
+*
+ IPIV( I ) = I
+*
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS and IPIV
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i) in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.(I+1) ) THEN
+ CALL ZSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ END IF
+*
+* Convert IPIV
+* There is one interchange of rows i+1 and IPIV(i+1),
+* so this should be recorded in consecutive entries
+* in IPIV format for *SYTRF
+*
+ IPIV( I ) = IPIV( I+1 )
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of ZSYCONVF
+*
+ END
--- /dev/null
+*> \brief \b ZSYCONVF_ROOK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYCONVF_ROOK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsyconvf_rook.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsyconvf_rook.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsyconvf_rook.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYCONVF_ROOK( UPLO, WAY, N, A, LDA, IPIV, E, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO, WAY
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> If parameter WAY = 'C':
+*> ZSYCONVF_ROOK converts the factorization output format used in
+*> ZSYTRF_ROOK provided on entry in parameter A into the factorization
+*> output format used in ZSYTRF_RK (or ZSYTRF_BK) that is stored
+*> on exit in parameters A and E. IPIV format for ZSYTRF_ROOK and
+*> ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted.
+*>
+*> If parameter WAY = 'R':
+*> ZSYCONVF_ROOK performs the conversion in reverse direction, i.e.
+*> converts the factorization output format used in ZSYTRF_RK
+*> (or ZSYTRF_BK) provided on entry in parametes A and E into
+*> the factorization output format used in ZSYTRF_ROOK that is stored
+*> on exit in parameter A. IPIV format for ZSYTRF_ROOK and
+*> ZSYTRF_RK (or ZSYTRF_BK) is the same and is not converted.
+*>
+*> ZSYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between
+*> formats used in ZHETRF_ROOK and ZHETRF_RK (or ZHETRF_BK).
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix A.
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] WAY
+*> \verbatim
+*> WAY is CHARACTER*1
+*> = 'C': Convert
+*> = 'R': Revert
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, contains factorization details in format used in
+*> ZSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> ZSYTRF_RK or ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains factorization details in format used in
+*> ZSYTRF_RK or ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, contains factorization details in format used in
+*> ZSYTRF_ROOK:
+*> a) all elements of the symmetric block diagonal
+*> matrix D on the diagonal of A and on superdiagonal
+*> (or subdiagonal) of A, and
+*> b) If UPLO = 'U': multipliers used to obtain factor U
+*> in the superdiagonal part of A.
+*> If UPLO = 'L': multipliers used to obtain factor L
+*> in the superdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in,out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*>
+*> 1) If WAY ='C':
+*>
+*> On entry, just a workspace.
+*>
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> 2) If WAY = 'R':
+*>
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> On exit, is not changed
+*> \endverbatim
+*.
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> On entry, details of the interchanges and the block
+*> structure of D as determined:
+*> 1) by ZSYTRF_ROOK, if WAY ='C';
+*> 2) by ZSYTRF_RK (or ZSYTRF_BK), if WAY ='R'.
+*> The IPIV format is the same for all these routines.
+*>
+*> On exit, is not changed.
+*> \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.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+* =====================================================================
+ SUBROUTINE ZSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, WAY
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ZERO
+ PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+*
+* .. External Subroutines ..
+ EXTERNAL ZSWAP, XERBLA
+* .. Local Scalars ..
+ LOGICAL UPPER, CONVERT
+ INTEGER I, IP, IP2
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ CONVERT = LSAME( WAY, 'C' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.CONVERT .AND. .NOT.LSAME( WAY, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYCONVF_ROOK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin A is UPPER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is upper)
+*
+*
+* Convert VALUE
+*
+* Assign superdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = N
+ E( 1 ) = ZERO
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ E( I ) = A( I-1, I )
+ E( I-1 ) = ZERO
+ A( I-1, I ) = ZERO
+ I = I - 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I - 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i-1 and IPIV(i-1)
+* in A(1:i,N-i:N)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-I, A( I, I+1 ), LDA,
+ $ A( IP, I+1 ), LDA )
+ END IF
+ IF( IP2.NE.(I-1) ) THEN
+ CALL ZSWAP( N-I, A( I-1, I+1 ), LDA,
+ $ A( IP2, I+1 ), LDA )
+ END IF
+ END IF
+ I = I - 1
+*
+ END IF
+ I = I - 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is upper)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of upper part of A
+* in reverse factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(1:i,N-i:N)
+*
+ IP = IPIV( I )
+ IF( I.LT.N ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i-1 and IPIV(i-1) and i and IPIV(i)
+* in A(1:i,N-i:N)
+*
+ I = I + 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I-1 )
+ IF( I.LT.N ) THEN
+ IF( IP2.NE.(I-1) ) THEN
+ CALL ZSWAP( N-I, A( IP2, I+1 ), LDA,
+ $ A( I-1, I+1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-I, A( IP, I+1 ), LDA,
+ $ A( I, I+1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I + 1
+ END DO
+*
+* Revert VALUE
+* Assign superdiagonal entries of D from array E to
+* superdiagonal entries of A.
+*
+ I = N
+ DO WHILE ( I.GT.1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I-1, I ) = E( I )
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* End A is UPPER
+*
+ END IF
+*
+ ELSE
+*
+* Begin A is LOWER
+*
+ IF ( CONVERT ) THEN
+*
+* Convert A (A is lower)
+*
+*
+* Convert VALUE
+* Assign subdiagonal entries of D to array E and zero out
+* corresponding entries in input storage A
+*
+ I = 1
+ E( N ) = ZERO
+ DO WHILE ( I.LE.N )
+ IF( I.LT.N .AND. IPIV(I).LT.0 ) THEN
+ E( I ) = A( I+1, I )
+ E( I+1 ) = ZERO
+ A( I+1, I ) = ZERO
+ I = I + 1
+ ELSE
+ E( I ) = ZERO
+ END IF
+ I = I + 1
+ END DO
+*
+* Convert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in factorization order where i increases from 1 to N
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i and IPIV(i) and i+1 and IPIV(i+1)
+* in A(i:N,1:i-1)
+*
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( I-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ IF( IP2.NE.(I+1) ) THEN
+ CALL ZSWAP( I-1, A( I+1, 1 ), LDA,
+ $ A( IP2, 1 ), LDA )
+ END IF
+ END IF
+ I = I + 1
+*
+ END IF
+ I = I + 1
+ END DO
+*
+ ELSE
+*
+* Revert A (A is lower)
+*
+*
+* Revert PERMUTATIONS
+*
+* Apply permutaions to submatrices of lower part of A
+* in reverse factorization order where i decreases from N to 1
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+*
+* 1-by-1 pivot interchange
+*
+* Swap rows i and IPIV(i) in A(i:N,1:i-1)
+*
+ IP = IPIV( I )
+ IF ( I.GT.1 ) THEN
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot interchange
+*
+* Swap rows i+1 and IPIV(i+1) and i and IPIV(i)
+* in A(i:N,1:i-1)
+*
+ I = I - 1
+ IP = -IPIV( I )
+ IP2 = -IPIV( I+1 )
+ IF ( I.GT.1 ) THEN
+ IF( IP2.NE.(I+1) ) THEN
+ CALL ZSWAP( I-1, A( IP2, 1 ), LDA,
+ $ A( I+1, 1 ), LDA )
+ END IF
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( I-1, A( IP, 1 ), LDA,
+ $ A( I, 1 ), LDA )
+ END IF
+ END IF
+*
+ END IF
+ I = I - 1
+ END DO
+*
+* Revert VALUE
+* Assign subdiagonal entries of D from array E to
+* subgiagonal entries of A.
+*
+ I = 1
+ DO WHILE ( I.LE.N-1 )
+ IF( IPIV( I ).LT.0 ) THEN
+ A( I + 1, I ) = E( I )
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+ END IF
+*
+* End A is LOWER
+*
+ END IF
+
+ RETURN
+*
+* End of ZSYCONVF_ROOK
+*
+ END
--- /dev/null
+*> \brief <b> ZSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices</b>
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYSV_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsysv_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsysv_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsysv_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYSV_RK computes the solution to a complex system of linear
+*> equations A * X = B, where A is an N-by-N symmetric matrix
+*> and X and B are N-by-NRHS matrices.
+*>
+*> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
+*> to factor A as
+*> A = P*U*D*(U**T)*(P**T), if UPLO = 'U', or
+*> A = P*L*D*(L**T)*(P**T), if UPLO = 'L',
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> ZSYTRF_RK is called to compute the factorization of a complex
+*> symmetric matrix. The factored form of A is then used to solve
+*> the system of equations A * X = B by calling BLAS3 routine ZSYTRS_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of linear equations, i.e., the order 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,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, if INFO = 0, diagonal of the block diagonal
+*> matrix D and factors U or L as computed by ZSYTRF_RK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> For more info see the description of ZSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the output computed by the factorization
+*> routine ZSYTRF_RK, i.e. the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*>
+*> For more info see the description of ZSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D,
+*> as determined by ZSYTRF_RK.
+*>
+*> For more info see the description of ZSYTRF_RK routine.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the N-by-NRHS right hand side matrix B.
+*> On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension ( MAX(1,LWORK) ).
+*> Work array used in the factorization stage.
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= 1. For best performance
+*> of factorization stage LWORK >= max(1,N*NB), where NB is
+*> the optimal blocksize for ZSYTRF_RK.
+*>
+*> If LWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of the WORK
+*> array for factorization stage, 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYsolve
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA, ZSYTRF_RK, ZSYTRS_3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ CALL ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, -1, INFO )
+ LWKOPT = WORK(1)
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYSV_RK ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = P*U*D*(U**T)*(P**T) or
+* A = P*U*D*(U**T)*(P**T).
+*
+ CALL ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B with BLAS3 solver, overwriting B with X.
+*
+ CALL ZSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of ZSYSV_RK
+*
+ END
--- /dev/null
+*> \brief \b ZSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS2 unblocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTF2_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytf2_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytf2_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytf2_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E ( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYTF2_RK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*>
+*> < 0: If INFO = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put further details
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> 01-01-96 - Based on modifications by
+*> J. Lewis, Boeing Computer Services Company
+*> A. Petitet, Computer Science Dept.,
+*> Univ. of Tenn., Knoxville abd , USA
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTF2_RK( UPLO, N, A, LDA, E, IPIV, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER, DONE
+ INTEGER I, IMAX, J, JMAX, ITEMP, K, KK, KP, KSTEP,
+ $ P, II
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, ROWMAX, DTEMP, SFMIN
+ COMPLEX*16 D11, D12, D21, D22, T, WK, WKM1, WKP1, Z
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IZAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IZAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZSCAL, ZSWAP, ZSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT, DIMAG, DBLE
+* ..
+* .. Statement Functions ..
+ DOUBLE PRECISION CABS1
+* ..
+* .. Statement Function definitions ..
+ CABS1( Z ) = ABS( DBLE( Z ) ) + ABS( DIMAG( Z ) )
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTF2_RK', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH( 'S' )
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* Initilize the first entry of array E, where superdiagonal
+* elements of D are stored
+*
+ E( 1 ) = CZERO
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 34
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IZAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.GT.1 )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange,
+* use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 12 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = IMAX + IZAMAX( K-IMAX, A( IMAX, IMAX+1 ),
+ $ LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.GT.1 ) THEN
+ ITEMP = IZAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ))
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 12
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the leading
+* submatrix A(1:k,1:k) if we have a 2-by-2 pivot
+*
+ IF( P.GT.1 )
+ $ CALL ZSWAP( P-1, A( 1, K ), 1, A( 1, P ), 1 )
+ IF( P.LT.(K-1) )
+ $ CALL ZSWAP( K-P-1, A( P+1, K ), 1, A( P, P+1 ),
+ $ LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( K, K+1 ), LDA, A( P, K+1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ IF( KP.GT.1 )
+ $ CALL ZSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ IF( ( KK.GT.1 ) .AND. ( KP.LT.(KK-1) ) )
+ $ CALL ZSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert upper triangle of A into U form by applying
+* the interchanges in columns k+1:N.
+*
+ IF( K.LT.N )
+ $ CALL ZSWAP( N-K, A( KK, K+1 ), LDA, A( KP, K+1 ),
+ $ LDA )
+*
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+ IF( K.GT.1 ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) and
+* store U(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*1/D(k)*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL ZSCAL( K-1, D11, A( 1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column K
+*
+ D11 = A( K, K )
+ DO 16 II = 1, K - 1
+ A( II, K ) = A( II, K ) / D11
+ 16 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - U(k)*D(k)*U(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZSYR( UPLO, K-1, -D11, A( 1, K ), 1, A, LDA )
+ END IF
+*
+* Store the superdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**T
+* = A - ( ( A(k-1)A(k) )*inv(D(k)) ) * ( A(k-1)A(k) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 30 J = K - 2, 1, -1
+*
+ WKM1 = T*( D11*A( J, K-1 )-A( J, K ) )
+ WK = T*( D22*A( J, K )-A( J, K-1 ) )
+*
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - (A( I, K ) / D12 )*WK -
+ $ ( A( I, K-1 ) / D12 )*WKM1
+ 20 CONTINUE
+*
+* Store U(k) and U(k-1) in cols k and k-1 for row J
+*
+ A( J, K ) = WK / D12
+ A( J, K-1 ) = WKM1 / D12
+*
+ 30 CONTINUE
+*
+ END IF
+*
+* Copy superdiagonal elements of D(K) to E(K) and
+* ZERO out superdiagonal entry of A
+*
+ E( K ) = A( K-1, K )
+ E( K-1 ) = CZERO
+ A( K-1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 34 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* Initilize the unused last entry of the subdiagonal array E.
+*
+ E( N ) = CZERO
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 64
+ KSTEP = 1
+ P = K
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = CABS1( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value.
+* Determine both COLMAX and IMAX.
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IZAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = CABS1( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( ( MAX( ABSAKK, COLMAX ).EQ.ZERO ) ) THEN
+*
+* Column K is zero or underflow: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+*
+* Set E( K ) to zero
+*
+ IF( K.LT.N )
+ $ E( K ) = CZERO
+*
+ ELSE
+*
+* Test for interchange
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABSAKK.GE.ALPHA*COLMAX
+*
+ IF( .NOT.( ABSAKK.LT.ALPHA*COLMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+*
+ ELSE
+*
+ DONE = .FALSE.
+*
+* Loop until pivot found
+*
+ 42 CONTINUE
+*
+* Begin pivot search loop body
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value.
+* Determine both ROWMAX and JMAX.
+*
+ IF( IMAX.NE.K ) THEN
+ JMAX = K - 1 + IZAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = CABS1( A( IMAX, JMAX ) )
+ ELSE
+ ROWMAX = ZERO
+ END IF
+*
+ IF( IMAX.LT.N ) THEN
+ ITEMP = IMAX + IZAMAX( N-IMAX, A( IMAX+1, IMAX ),
+ $ 1 )
+ DTEMP = CABS1( A( ITEMP, IMAX ) )
+ IF( DTEMP.GT.ROWMAX ) THEN
+ ROWMAX = DTEMP
+ JMAX = ITEMP
+ END IF
+ END IF
+*
+* Equivalent to testing for (used to handle NaN and Inf)
+* ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX
+*
+ IF( .NOT.( CABS1( A( IMAX, IMAX ) ).LT.ALPHA*ROWMAX ))
+ $ THEN
+*
+* interchange rows and columns K and IMAX,
+* use 1-by-1 pivot block
+*
+ KP = IMAX
+ DONE = .TRUE.
+*
+* Equivalent to testing for ROWMAX .EQ. COLMAX,
+* used to handle NaN and Inf
+*
+ ELSE IF( ( P.EQ.JMAX ).OR.( ROWMAX.LE.COLMAX ) ) THEN
+*
+* interchange rows and columns K+1 and IMAX,
+* use 2-by-2 pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ DONE = .TRUE.
+ ELSE
+*
+* Pivot NOT found, set variables and repeat
+*
+ P = IMAX
+ COLMAX = ROWMAX
+ IMAX = JMAX
+ END IF
+*
+* End pivot search loop body
+*
+ IF( .NOT. DONE ) GOTO 42
+*
+ END IF
+*
+* Swap TWO rows and TWO columns
+*
+* First swap
+*
+ IF( ( KSTEP.EQ.2 ) .AND. ( P.NE.K ) ) THEN
+*
+* Interchange rows and column K and P in the trailing
+* submatrix A(k:n,k:n) if we have a 2-by-2 pivot
+*
+ IF( P.LT.N )
+ $ CALL ZSWAP( N-P, A( P+1, K ), 1, A( P+1, P ), 1 )
+ IF( P.GT.(K+1) )
+ $ CALL ZSWAP( P-K-1, A( K+1, K ), 1, A( P, K+1 ), LDA )
+ T = A( K, K )
+ A( K, K ) = A( P, P )
+ A( P, P ) = T
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( K, 1 ), LDA, A( P, 1 ), LDA )
+*
+ END IF
+*
+* Second swap
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL ZSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ IF( ( KK.LT.N ) .AND. ( KP.GT.(KK+1) ) )
+ $ CALL ZSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+*
+* Convert lower triangle of A into L form by applying
+* the interchanges in columns 1:k-1.
+*
+ IF ( K.GT.1 )
+ $ CALL ZSWAP( K-1, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+*
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) and
+* store L(k) in column k
+*
+ IF( CABS1( A( K, K ) ).GE.SFMIN ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+*
+ D11 = CONE / A( K, K )
+ CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column k
+*
+ CALL ZSCAL( N-K, D11, A( K+1, K ), 1 )
+ ELSE
+*
+* Store L(k) in column k
+*
+ D11 = A( K, K )
+ DO 46 II = K + 1, N
+ A( II, K ) = A( II, K ) / D11
+ 46 CONTINUE
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+* A := A - L(k)*D(k)*L(k)**T
+* = A - W(k)*(1/D(k))*W(k)**T
+* = A - (W(k)/D(k))*(D(k))*(W(k)/D(K))**T
+*
+ CALL ZSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+ END IF
+*
+* Store the subdiagonal element of D in array E
+*
+ E( K ) = CZERO
+*
+ END IF
+*
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) ) * D(k) * ( L(k) L(k+1) )**T
+* = A - ( ( A(k)A(k+1) )*inv(D(k) ) * ( A(k)A(k+1) )**T
+*
+* and store L(k) and L(k+1) in columns k and k+1
+*
+ IF( K.LT.N-1 ) THEN
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = CONE / ( D11*D22-CONE )
+*
+ DO 60 J = K + 2, N
+*
+* Compute D21 * ( W(k)W(k+1) ) * inv(D(k)) for row J
+*
+ WK = T*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = T*( D22*A( J, K+1 )-A( J, K ) )
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n)
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - ( A( I, K ) / D21 )*WK -
+ $ ( A( I, K+1 ) / D21 )*WKP1
+ 50 CONTINUE
+*
+* Store L(k) and L(k+1) in cols k and k+1 for row J
+*
+ A( J, K ) = WK / D21
+ A( J, K+1 ) = WKP1 / D21
+*
+ 60 CONTINUE
+*
+ END IF
+*
+* Copy subdiagonal elements of D(K) to E(K) and
+* ZERO out subdiagonal entry of A
+*
+ E( K ) = A( K+1, K )
+ E( K+1 ) = CZERO
+ A( K+1, K ) = CZERO
+*
+ END IF
+*
+* End column K is nonsingular
+*
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -P
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ 64 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of ZSYTF2_RK
+*
+ END
--- /dev/null
+*> \brief \b ZSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm).
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRF_RK + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytrf_rk.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytrf_rk.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytrf_rk.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYTRF_RK computes the factorization of a complex symmetric matrix A
+*> using the bounded Bunch-Kaufman (rook) diagonal pivoting method:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> For more information see Further Details section.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, the symmetric matrix A.
+*> If UPLO = 'U': the leading N-by-N upper triangular part
+*> of A contains the upper triangular part of the matrix A,
+*> and the strictly lower triangular part of A is not
+*> referenced.
+*>
+*> If UPLO = 'L': the leading N-by-N lower triangular part
+*> of A contains the lower triangular part of the matrix A,
+*> and the strictly upper triangular part of A is not
+*> referenced.
+*>
+*> On exit, contains:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> are stored on exit in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On exit, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is set to 0 in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[out] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> IPIV describes the permutation matrix P in the factorization
+*> of matrix A as follows. The absolute value of IPIV(k)
+*> represents the index of row and column that were
+*> interchanged with the k-th row and column. The value of UPLO
+*> describes the order in which the interchanges were applied.
+*> Also, the sign of IPIV represents the block structure of
+*> the symmetric block diagonal matrix D with 1-by-1 or 2-by-2
+*> diagonal blocks which correspond to 1 or 2 interchanges
+*> at each factorization step. For more info see Further
+*> Details section.
+*>
+*> If UPLO = 'U',
+*> ( in factorization order, k decreases from N to 1 ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N);
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k-1) < 0 means:
+*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k-1) != k-1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k-1) = k-1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) <= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*>
+*> If UPLO = 'L',
+*> ( in factorization order, k increases from 1 to N ):
+*> a) A single positive entry IPIV(k) > 0 means:
+*> D(k,k) is a 1-by-1 diagonal block.
+*> If IPIV(k) != k, rows and columns k and IPIV(k) were
+*> interchanged in the matrix A(1:N,1:N).
+*> If IPIV(k) = k, no interchange occurred.
+*>
+*> b) A pair of consecutive negative entries
+*> IPIV(k) < 0 and IPIV(k+1) < 0 means:
+*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*> (NOTE: negative entries in IPIV appear ONLY in pairs).
+*> 1) If -IPIV(k) != k, rows and columns
+*> k and -IPIV(k) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k) = k, no interchange occurred.
+*> 2) If -IPIV(k+1) != k+1, rows and columns
+*> k-1 and -IPIV(k-1) were interchanged
+*> in the matrix A(1:N,1:N).
+*> If -IPIV(k+1) = k+1, no interchange occurred.
+*>
+*> c) In both cases a) and b), always ABS( IPIV(k) ) >= k.
+*>
+*> d) NOTE: Any entry IPIV(k) is always NONZERO on output.
+*> \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 length of WORK. LWORK >=1. For best performance
+*> LWORK >= N*NB, where NB is the block size returned
+*> by ILAENV.
+*>
+*> 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 = -k, the k-th argument had an illegal value
+*>
+*> > 0: If INFO = k, the matrix A is singular, because:
+*> If UPLO = 'U': column k in the upper
+*> triangular part of A contains all zeros.
+*> If UPLO = 'L': column k in the lower
+*> triangular part of A contains all zeros.
+*>
+*> Therefore D(k,k) is exactly zero, and superdiagonal
+*> elements of column k of U (or subdiagonal elements of
+*> column k of L ) are all zeros. The factorization has
+*> been completed, but the block diagonal matrix D is
+*> exactly singular, and division by zero will occur if
+*> it is used to solve a system of equations.
+*>
+*> NOTE: INFO only stores the first occurrence of
+*> a singularity, any subsequent occurrence of singularity
+*> is not stored in INFO even though the factorization
+*> always completes.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*> TODO: put correct description
+*> \endverbatim
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IP, IWS, K, KB, LDWORK, LWKOPT,
+ $ NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLASYF_RK, ZSYTF2_RK, ZSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'ZSYTRF_RK', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRF_RK', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'ZSYTRF_RK',
+ $ UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U**T using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by ZLASYF_RK;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 15
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL ZLASYF_RK( UPLO, K, NB, KB, A, LDA, E,
+ $ IPIV, WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL ZSYTF2_RK( UPLO, K, A, LDA, E, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* No need to adjust IPIV
+*
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k-kb+1:k and apply row permutations to the
+* last k+1 colunms k+1:N after that block
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.LT.N ) THEN
+ DO I = K, ( K - KB + 1 ), -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( N-K, A( I, K+1 ), LDA,
+ $ A( IP, K+1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+* This label is the exit from main loop over K decreasing
+* from N to 1 in steps of KB
+*
+ 15 CONTINUE
+*
+ ELSE
+*
+* Factorize A as L*D*L**T using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by ZLASYF_RK;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 35
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL ZLASYF_RK( UPLO, N-K+1, NB, KB, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), WORK, LDWORK, IINFO )
+
+
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL ZSYTF2_RK( UPLO, N-K+1, A( K, K ), LDA, E( K ),
+ $ IPIV( K ), IINFO )
+ KB = N - K + 1
+*
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO I = K, K + KB - 1
+ IF( IPIV( I ).GT.0 ) THEN
+ IPIV( I ) = IPIV( I ) + K - 1
+ ELSE
+ IPIV( I ) = IPIV( I ) - K + 1
+ END IF
+ END DO
+*
+* Apply permutations to the leading panel 1:k-1
+*
+* Read IPIV from the last block factored, i.e.
+* indices k:k+kb-1 and apply row permutations to the
+* first k-1 colunms 1:k-1 before that block
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV( I ) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ IF( K.GT.1 ) THEN
+ DO I = K, ( K + KB - 1 ), 1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ CALL ZSWAP( K-1, A( I, 1 ), LDA,
+ $ A( IP, 1 ), LDA )
+ END IF
+ END DO
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+* This label is the exit from main loop over K increasing
+* from 1 to N in steps of KB
+*
+ 35 CONTINUE
+*
+* End Lower
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of ZSYTRF_RK
+*
+ END
--- /dev/null
+*> \brief \b ZSYTRI_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRI_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytri_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytri_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytri_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYTRI_3 computes the inverse of a complex symmetric indefinite
+*> matrix A using the factorization computed by ZSYTRF_RK or ZSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> ZSYTRI_3 sets the leading dimension of the workspace before calling
+*> ZSYTRI_3X that actually computes the inverse. This is the blocked
+*> version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by ZSYTRF_RK and ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_RK or ZSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (N+NB+1)*(NB+3).
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The length of WORK. LWORK >= (N+NB+1)*(NB+3).
+*>
+*> If LDWORK = -1, then a workspace query is assumed;
+*> the routine only calculates the optimal size of 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
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZSYTRI_3X
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* Determine the block size
+*
+ NB = MAX( 1, ILAENV( 1, 'ZSYTRI_3', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = ( N+NB+1 ) * ( NB+3 )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF ( LWORK .LT. LWKOPT .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRI_3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ WORK( 1 ) = LWKOPT
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ CALL ZSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of ZSYTRI_3
+*
+ END
--- /dev/null
+*> \brief \b ZSYTRI_3X
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRI_3X + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytri_3x.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytri_3x.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytri_3x.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYTRI_3X computes the inverse of a complex symmetric indefinite
+*> matrix A using the factorization computed by ZSYTRF_RK or ZSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This is the blocked version of the algorithm, calling Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix.
+*> = 'U': Upper triangle of A is stored;
+*> = 'L': Lower triangle of A is stored.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in,out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> On entry, diagonal of the block diagonal matrix D and
+*> factors U or L as computed by ZSYTRF_RK and ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*>
+*> On exit, if INFO = 0, the symmetric inverse of the original
+*> matrix.
+*> If UPLO = 'U': the upper triangular part of the inverse
+*> is formed and the part of A below the diagonal is not
+*> referenced;
+*> If UPLO = 'L': the lower triangular part of the inverse
+*> is formed and the part of A above the diagonal is not
+*> referenced.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_RK or ZSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (N+NB+1,NB+3).
+*> \endverbatim
+*>
+*> \param[in] NB
+*> \verbatim
+*> NB is INTEGER
+*> Block size.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit
+*> < 0: if INFO = -i, the i-th argument had an illegal value
+*> > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+*> inverse could not be computed.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 CONE, CZERO
+ PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ),
+ $ CZERO = ( 0.0D+0, 0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER CUT, I, ICOUNT, INVD, IP, K, NNB, J, U11
+ COMPLEX*16 AK, AKKP1, AKP1, D, T, U01_I_J, U01_IP1_J,
+ $ U11_I_J, U11_IP1_J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMM, ZSYSWAPR, ZTRTRI, ZTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+*
+* Quick return if possible
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRI_3X', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Workspace got Non-diag elements of D
+*
+ DO K = 1, N
+ WORK( K, 1 ) = E( K )
+ END DO
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.CZERO )
+ $ RETURN
+ END DO
+ END IF
+*
+ INFO = 0
+*
+* Splitting Workspace
+* U01 is a block ( N, NB+1 )
+* The first element of U01 is in WORK( 1, 1 )
+* U11 is a block ( NB+1, NB+1 )
+* The first element of U11 is in WORK( N+1, 1 )
+*
+ U11 = N
+*
+* INVD is a block ( N, 2 )
+* The first element of INVD is in WORK( 1, INVD )
+*
+ INVD = NB + 2
+
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* invA = P * inv(U**T) * inv(D) * inv(U) * P**T.
+*
+ CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(U)
+*
+ K = 1
+ DO WHILE( K.LE.N )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = CONE / A( K, K )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K+1, 1 )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = WORK( K+1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K, INVD ) = AKP1 / D
+ WORK( K+1, INVD+1 ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K+1, INVD ) = WORK( K, INVD+1 )
+ K = K + 1
+ END IF
+ K = K + 1
+ END DO
+*
+* inv(U**T) = (inv(U))**T
+*
+* inv(U**T) * inv(D) * inv(U)
+*
+ CUT = N
+ DO WHILE( CUT.GT.0 )
+ NNB = NB
+ IF( CUT.LE.NNB ) THEN
+ NNB = CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT+1-NNB, CUT
+ IF( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+
+ CUT = CUT - NNB
+*
+* U01 Block
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ WORK( I, J ) = A( I, CUT+J )
+ END DO
+ END DO
+*
+* U11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I ) = CONE
+ DO J = 1, I-1
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD * U01
+*
+ I = 1
+ DO WHILE( I.LE.CUT )
+ IF( IPIV( I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( I, INVD ) * WORK( I, J )
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK( I, J )
+ U01_IP1_J = WORK( I+1, J )
+ WORK( I, J ) = WORK( I, INVD ) * U01_I_J
+ $ + WORK( I, INVD+1 ) * U01_IP1_J
+ WORK( I+1, J ) = WORK( I+1, INVD ) * U01_I_J
+ $ + WORK( I+1, INVD+1 ) * U01_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* invD1 * U11
+*
+ I = 1
+ DO WHILE ( I.LE.NNB )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = I, NNB
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ END DO
+ ELSE
+ DO J = I, NNB
+ U11_I_J = WORK(U11+I,J)
+ U11_IP1_J = WORK(U11+I+1,J)
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * WORK(U11+I+1,J)
+ WORK( U11+I+1, J ) = WORK(CUT+I+1,INVD) * U11_I_J
+ $ + WORK(CUT+I+1,INVD+1) * U11_IP1_J
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* U11**T * invD1 * U11 -> U11
+*
+ CALL ZTRMM( 'L', 'U', 'T', 'U', NNB, NNB,
+ $ CONE, A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+* U01**T * invD * U01 -> A( CUT+I, CUT+J )
+*
+ CALL ZGEMM( 'T', 'N', NNB, NNB, CUT, CONE, A( 1, CUT+1 ),
+ $ LDA, WORK, N+NB+1, CZERO, WORK(U11+1,1),
+ $ N+NB+1 )
+
+*
+* U11 = U11**T * invD1 * U11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = I, NNB
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J ) + WORK(U11+I,J)
+ END DO
+ END DO
+*
+* U01 = U00**T * invD0 * U01
+*
+ CALL ZTRMM( 'L', UPLO, 'T', 'U', CUT, NNB,
+ $ CONE, A, LDA, WORK, N+NB+1 )
+
+*
+* Update U01
+*
+ DO I = 1, CUT
+ DO J = 1, NNB
+ A( I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+* Next Block
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(U**T) * inv(D) * inv(U) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Upper case.
+*
+* ( We can use a loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = 1, N
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T.
+*
+ CALL ZTRTRI( UPLO, 'U', N, A, LDA, INFO )
+*
+* inv(D) and inv(D) * inv(L)
+*
+ K = N
+ DO WHILE ( K .GE. 1 )
+ IF( IPIV( K ).GT.0 ) THEN
+* 1 x 1 diagonal NNB
+ WORK( K, INVD ) = CONE / A( K, K )
+ WORK( K, INVD+1 ) = CZERO
+ ELSE
+* 2 x 2 diagonal NNB
+ T = WORK( K-1, 1 )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = WORK( K-1, 1 ) / T
+ D = T*( AK*AKP1-CONE )
+ WORK( K-1, INVD ) = AKP1 / D
+ WORK( K, INVD ) = AK / D
+ WORK( K, INVD+1 ) = -AKKP1 / D
+ WORK( K-1, INVD+1 ) = WORK( K, INVD+1 )
+ K = K - 1
+ END IF
+ K = K - 1
+ END DO
+*
+* inv(L**T) = (inv(L))**T
+*
+* inv(L**T) * inv(D) * inv(L)
+*
+ CUT = 0
+ DO WHILE( CUT.LT.N )
+ NNB = NB
+ IF( (CUT + NNB).GT.N ) THEN
+ NNB = N - CUT
+ ELSE
+ ICOUNT = 0
+* count negative elements,
+ DO I = CUT + 1, CUT+NNB
+ IF ( IPIV( I ).LT.0 ) ICOUNT = ICOUNT + 1
+ END DO
+* need a even number for a clear cut
+ IF( MOD( ICOUNT, 2 ).EQ.1 ) NNB = NNB + 1
+ END IF
+*
+* L21 Block
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ WORK( I, J ) = A( CUT+NNB+I, CUT+J )
+ END DO
+ END DO
+*
+* L11 Block
+*
+ DO I = 1, NNB
+ WORK( U11+I, I) = CONE
+ DO J = I+1, NNB
+ WORK( U11+I, J ) = CZERO
+ END DO
+ DO J = 1, I-1
+ WORK( U11+I, J ) = A( CUT+I, CUT+J )
+ END DO
+ END DO
+*
+* invD*L21
+*
+ I = N-CUT-NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+NNB+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( I, J ) = WORK( CUT+NNB+I, INVD) * WORK( I, J)
+ END DO
+ ELSE
+ DO J = 1, NNB
+ U01_I_J = WORK(I,J)
+ U01_IP1_J = WORK(I-1,J)
+ WORK(I,J)=WORK(CUT+NNB+I,INVD)*U01_I_J+
+ $ WORK(CUT+NNB+I,INVD+1)*U01_IP1_J
+ WORK(I-1,J)=WORK(CUT+NNB+I-1,INVD+1)*U01_I_J+
+ $ WORK(CUT+NNB+I-1,INVD)*U01_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* invD1*L11
+*
+ I = NNB
+ DO WHILE( I.GE.1 )
+ IF( IPIV( CUT+I ).GT.0 ) THEN
+ DO J = 1, NNB
+ WORK( U11+I, J ) = WORK( CUT+I, INVD)*WORK(U11+I,J)
+ END DO
+
+ ELSE
+ DO J = 1, NNB
+ U11_I_J = WORK( U11+I, J )
+ U11_IP1_J = WORK( U11+I-1, J )
+ WORK( U11+I, J ) = WORK(CUT+I,INVD) * WORK(U11+I,J)
+ $ + WORK(CUT+I,INVD+1) * U11_IP1_J
+ WORK( U11+I-1, J ) = WORK(CUT+I-1,INVD+1) * U11_I_J
+ $ + WORK(CUT+I-1,INVD) * U11_IP1_J
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* L11**T * invD1 * L11 -> L11
+*
+ CALL ZTRMM( 'L', UPLO, 'T', 'U', NNB, NNB, CONE,
+ $ A( CUT+1, CUT+1 ), LDA, WORK( U11+1, 1 ),
+ $ N+NB+1 )
+
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+*
+ IF( (CUT+NNB).LT.N ) THEN
+*
+* L21**T * invD2*L21 -> A( CUT+I, CUT+J )
+*
+ CALL ZGEMM( 'T', 'N', NNB, NNB, N-NNB-CUT, CONE,
+ $ A( CUT+NNB+1, CUT+1 ), LDA, WORK, N+NB+1,
+ $ CZERO, WORK( U11+1, 1 ), N+NB+1 )
+
+*
+* L11 = L11**T * invD1 * L11 + U01**T * invD * U01
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = A( CUT+I, CUT+J )+WORK(U11+I,J)
+ END DO
+ END DO
+*
+* L01 = L22**T * invD2 * L21
+*
+ CALL ZTRMM( 'L', UPLO, 'T', 'U', N-NNB-CUT, NNB, CONE,
+ $ A( CUT+NNB+1, CUT+NNB+1 ), LDA, WORK,
+ $ N+NB+1 )
+*
+* Update L21
+*
+ DO I = 1, N-CUT-NNB
+ DO J = 1, NNB
+ A( CUT+NNB+I, CUT+J ) = WORK( I, J )
+ END DO
+ END DO
+*
+ ELSE
+*
+* L11 = L11**T * invD1 * L11
+*
+ DO I = 1, NNB
+ DO J = 1, I
+ A( CUT+I, CUT+J ) = WORK( U11+I, J )
+ END DO
+ END DO
+ END IF
+*
+* Next Block
+*
+ CUT = CUT + NNB
+*
+ END DO
+*
+* Apply PERMUTATIONS P and P**T:
+* P * inv(L**T) * inv(D) * inv(L) * P**T.
+* Interchange rows and columns I and IPIV(I) in reverse order
+* from the formation order of IPIV vector for Lower case.
+*
+* ( We can use a loop over IPIV with increment -1,
+* since the ABS value of IPIV(I) represents the row (column)
+* index of the interchange with row (column) i in both 1x1
+* and 2x2 pivot cases, i.e. we don't need separate code branches
+* for 1x1 and 2x2 pivot cases )
+*
+ DO I = N, 1, -1
+ IP = ABS( IPIV( I ) )
+ IF( IP.NE.I ) THEN
+ IF (I .LT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, I ,IP )
+ IF (I .GT. IP) CALL ZSYSWAPR( UPLO, N, A, LDA, IP ,I )
+ END IF
+ END DO
+*
+ END IF
+*
+ RETURN
+*
+* End of ZSYTRI_3X
+*
+ END
+
--- /dev/null
+*> \brief \b ZSYTRS_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZSYTRS_3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zsytrs_3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zsytrs_3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zsytrs_3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> ZSYTRS_3 solves a system of linear equations A * X = B with a complex
+*> symmetric matrix A using the factorization computed
+*> by ZSYTRF_RK or ZSYTRF_BK:
+*>
+*> A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T),
+*>
+*> where U (or L) is unit upper (or lower) triangular matrix,
+*> U**T (or L**T) is the transpose of U (or L), P is a permutation
+*> matrix, P**T is the transpose of P, and D is symmetric and block
+*> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*>
+*> This algorithm is using Level 3 BLAS.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the details of the factorization are
+*> stored as an upper or lower triangular matrix:
+*> = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T);
+*> = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T).
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The order 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] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by ZSYTRF_RK and ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*>
+*> NOTE: For 1-by-1 diagonal block D(k), where
+*> 1 <= k <= N, the element E(k) is not referenced in both
+*> UPLO = 'U' or UPLO = 'L' cases.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> Details of the interchanges and the block structure of D
+*> as determined by ZSYTRF_RK or ZSYTRF_BK.
+*> \endverbatim
+*>
+*> \param[in,out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (LDB,NRHS)
+*> On entry, the right hand side matrix B.
+*> On exit, the solution matrix X.
+*> \endverbatim
+*>
+*> \param[in] LDB
+*> \verbatim
+*> LDB is INTEGER
+*> The leading dimension of the array B. LDB >= max(1,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.
+*
+*> \date November 2016
+*
+*> \ingroup complex16SYcomputational
+*
+*> \par Contributors:
+* ==================
+*>
+*> \verbatim
+*>
+*> November 2016, Igor Kozachenko,
+*> Computer Science Division,
+*> University of California, Berkeley
+*>
+*> September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
+*> School of Mathematics,
+*> University of Manchester
+*>
+*> \endverbatim
+*
+* =====================================================================
+ SUBROUTINE ZSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = ( 1.0D+0,0.0D+0 ) )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J, K, KP
+ COMPLEX*16 AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZSCAL, ZSWAP, ZTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'ZSYTRS_3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Begin Upper
+*
+* Solve A*X = B, where A = U*D*U**T.
+*
+* P**T * B
+*
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (U \P**T * B) -> B [ (U \P**T * B) ]
+*
+ CALL ZTRSM( 'L', 'U', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (U \P**T * B) ]
+*
+ I = N
+ DO WHILE ( I.GE.1 )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL ZSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF ( I.GT.1 ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I-1, I-1 ) / AKM1K
+ AK = A( I, I ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I-1, J ) / AKM1K
+ BK = B( I, J ) / AKM1K
+ B( I-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I - 1
+ END IF
+ I = I - 1
+ END DO
+*
+* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ]
+*
+ CALL ZTRSM( 'L', 'U', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Upper case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+ ELSE
+*
+* Begin Lower
+*
+* Solve A*X = B, where A = L*D*L**T.
+*
+* P**T * B
+* Interchange rows K and IPIV(K) of matrix B in the same order
+* that the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with increment 1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = 1, N, 1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* Compute (L \P**T * B) -> B [ (L \P**T * B) ]
+*
+ CALL ZTRSM( 'L', 'L', 'N', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* Compute D \ B -> B [ D \ (L \P**T * B) ]
+*
+ I = 1
+ DO WHILE ( I.LE.N )
+ IF( IPIV( I ).GT.0 ) THEN
+ CALL ZSCAL( NRHS, ONE / A( I, I ), B( I, 1 ), LDB )
+ ELSE IF( I.LT.N ) THEN
+ AKM1K = E( I )
+ AKM1 = A( I, I ) / AKM1K
+ AK = A( I+1, I+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO J = 1, NRHS
+ BKM1 = B( I, J ) / AKM1K
+ BK = B( I+1, J ) / AKM1K
+ B( I, J ) = ( AK*BKM1-BK ) / DENOM
+ B( I+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ END DO
+ I = I + 1
+ END IF
+ I = I + 1
+ END DO
+*
+* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ]
+*
+ CALL ZTRSM('L', 'L', 'T', 'U', N, NRHS, ONE, A, LDA, B, LDB )
+*
+* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ]
+*
+* Interchange rows K and IPIV(K) of matrix B in reverse order
+* from the formation order of IPIV(I) vector for Lower case.
+*
+* (We can do the simple loop over IPIV with decrement -1,
+* since the ABS value of IPIV(I) represents the row index
+* of the interchange with row i in both 1x1 and 2x2 pivot cases)
+*
+ DO K = N, 1, -1
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+ CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ END IF
+ END DO
+*
+* END Lower
+*
+ END IF
+*
+ RETURN
+*
+* End of ZSYTRS_3
+*
+ END
schkeq.f schkgb.f schkge.f schkgt.f
schklq.f schkpb.f schkpo.f schkps.f schkpp.f
schkpt.f schkq3.f schkql.f schkqr.f schkrq.f
- schksp.f schksy.f schksy_rook.f schksy_aa.f schktb.f schktp.f schktr.f
+ schksp.f schksy.f schksy_rook.f schksy_rk.f schksy_aa.f schktb.f schktp.f schktr.f
schktz.f
sdrvgt.f sdrvls.f sdrvpb.f
- sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f sdrvsy_aa.f
+ sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f sdrvsy_rk.f sdrvsy_aa.f
serrgt.f serrlq.f serrls.f
serrpo.f serrps.f serrql.f serrqp.f serrqr.f
serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f
sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f
sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f
srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f
- sspt01.f ssyt01.f ssyt01_rook.f ssyt01_aa.f
+ sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f ssyt01_aa.f
stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f
stpt02.f stpt03.f stpt05.f stpt06.f strt01.f
strt02.f strt03.f strt05.f strt06.f
set(CLINTST cchkaa.f
cchkeq.f cchkgb.f cchkge.f cchkgt.f
- cchkhe.f cchkhe_rook.f cchkhe_aa.f cchkhp.f cchklq.f cchkpb.f
+ cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhp.f cchklq.f cchkpb.f
cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f
- cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchktb.f
+ cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchktb.f
cchktp.f cchktr.f cchktz.f
- cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhe_aa.f cdrvhp.f
+ cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhe_rk.f cdrvhe_aa.f cdrvhp.f
cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f
- cdrvsp.f cdrvsy.f cdrvsy_rook.f
+ cdrvsp.f cdrvsy.f cdrvsy_rook.f cdrvsy_rk.f
cerrgt.f cerrhe.f cerrlq.f
cerrls.f cerrps.f cerrql.f cerrqp.f
cerrqr.f cerrrq.f cerrsy.f cerrtr.f cerrtz.f
cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f
cgerqs.f cget01.f cget02.f
cget03.f cget04.f cget07.f cgtt01.f cgtt02.f
- cgtt05.f chet01.f chet01_rook.f chet01_aa.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f
+ cgtt05.f chet01.f chet01_rook.f chet01_3.f chet01_aa.f
+ chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f
clatsp.f clatsy.f clattb.f clattp.f clattr.f
clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f
clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f
cqrt12.f cqrt13.f cqrt14.f cqrt15.f cqrt16.f
cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f
csbmv.f cspt01.f
- cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt02.f csyt03.f
+ cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt01_3.f csyt02.f csyt03.f
ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f
ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f
ctrt02.f ctrt03.f ctrt05.f ctrt06.f
dchkeq.f dchkgb.f dchkge.f dchkgt.f
dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f
dchkpt.f dchkq3.f dchkql.f dchkqr.f dchkrq.f
- dchksp.f dchksy.f dchksy_rook.f dchksy_aa.f dchktb.f dchktp.f dchktr.f
+ dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchktb.f dchktp.f dchktr.f
dchktz.f
ddrvgt.f ddrvls.f ddrvpb.f
- ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f ddrvsy_aa.f
+ ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f ddrvsy_rk.f ddrvsy_aa.f
derrgt.f derrlq.f derrls.f
derrps.f derrql.f derrqp.f derrqr.f
derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f
dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f
dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f
drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f
- dspt01.f dsyt01.f dsyt01_rook.f dsyt01_aa.f
+ dspt01.f dsyt01.f dsyt01_rook.f dsyt01_3.f dsyt01_aa.f
dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f
dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f
dtrt02.f dtrt03.f dtrt05.f dtrt06.f
set(ZLINTST zchkaa.f
zchkeq.f zchkgb.f zchkge.f zchkgt.f
- zchkhe.f zchkhe_rook.f zchkhe_aa.f zchkhp.f zchklq.f zchkpb.f
+ zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhp.f zchklq.f zchkpb.f
zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f
- zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchktb.f
+ zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchktb.f
zchktp.f zchktr.f zchktz.f
- zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhe_aa.f zdrvhp.f
+ zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhe_rk.f zdrvhe_aa.f zdrvhp.f
zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f
- zdrvsp.f zdrvsy.f zdrvsy_rook.f
+ zdrvsp.f zdrvsy.f zdrvsy_rook.f zdrvsy_rk.f
zerrgt.f zerrhe.f zerrlq.f
zerrls.f zerrps.f zerrql.f zerrqp.f
zerrqr.f zerrrq.f zerrsy.f zerrtr.f zerrtz.f
zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f
zgerqs.f zget01.f zget02.f
zget03.f zget04.f zget07.f zgtt01.f zgtt02.f
- zgtt05.f zhet01.f zhet01_rook.f zhet01_aa.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f
+ zgtt05.f zhet01.f zhet01_rook.f zhet01_3.f zhet01_aa.f
+ zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f
zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f
zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f
zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f
zqrt12.f zqrt13.f zqrt14.f zqrt15.f zqrt16.f
zqrt17.f zrqt01.f zrqt02.f zrqt03.f zrzt01.f zrzt02.f
zsbmv.f zspt01.f
- zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt02.f zsyt03.f
+ zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt01_3.f zsyt02.f zsyt03.f
ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f
ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f
ztrt02.f ztrt03.f ztrt05.f ztrt06.f
schkeq.o schkgb.o schkge.o schkgt.o \
schklq.o schkpb.o schkpo.o schkps.o schkpp.o \
schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \
- schksp.o schksy.o schksy_rook.o schksy_aa.o schktb.o schktp.o schktr.o \
+ schksp.o schksy.o schksy_rook.o schksy_rk.o schksy_aa.o schktb.o schktp.o schktr.o \
schktz.o \
sdrvgt.o sdrvls.o sdrvpb.o \
- sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_aa.o\
+ sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_rk.o sdrvsy_aa.o\
serrgt.o serrlq.o serrls.o \
serrps.o serrql.o serrqp.o serrqr.o \
serrrq.o serrtr.o serrtz.o \
sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \
sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \
srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \
- sspt01.o ssyt01.o ssyt01_rook.o ssyt01_aa.o\
+ sspt01.o ssyt01.o ssyt01_rook.o ssyt01_3.o ssyt01_aa.o\
stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \
stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \
strt02.o strt03.o strt05.o strt06.o \
CLINTST = cchkaa.o \
cchkeq.o cchkgb.o cchkge.o cchkgt.o \
- cchkhe.o cchkhe_rook.o cchkhe_aa.o cchkhp.o cchklq.o cchkpb.o \
+ cchkhe.o cchkhe_rook.o cchkhe_rk.o cchkhe_aa.o cchkhp.o cchklq.o cchkpb.o \
cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \
- cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \
+ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o cchktb.o \
cchktp.o cchktr.o cchktz.o \
- cdrvgt.o cdrvhe_rook.o cdrvhe_aa.o cdrvhp.o \
+ cdrvgt.o cdrvhe_rook.o cdrvhe_rk.o cdrvhe_aa.o cdrvhp.o \
cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \
- cdrvsp.o cdrvsy_rook.o \
+ cdrvsp.o cdrvsy_rook.o cdrvsy_rk.o \
cerrgt.o cerrlq.o \
cerrls.o cerrps.o cerrql.o cerrqp.o \
cerrqr.o cerrrq.o cerrtr.o cerrtz.o \
cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \
cgerqs.o cget01.o cget02.o \
cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \
- cgtt05.o chet01.o chet01_rook.o chet01_aa.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
+ cgtt05.o chet01.o chet01_rook.o chet01_3.o \
+ chet01_aa.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \
clatsp.o clatsy.o clattb.o clattp.o clattr.o \
clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \
clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \
cqrt12.o cqrt13.o cqrt14.o cqrt15.o cqrt16.o \
cqrt17.o crqt01.o crqt02.o crqt03.o crzt01.o crzt02.o \
csbmv.o cspt01.o \
- cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt02.o csyt03.o \
+ cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt01_3.o csyt02.o csyt03.o \
ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \
ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \
ctrt02.o ctrt03.o ctrt05.o ctrt06.o \
dchkeq.o dchkgb.o dchkge.o dchkgt.o \
dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \
dchkpt.o dchkq3.o dchkql.o dchkqr.o dchkrq.o \
- dchksp.o dchksy.o dchksy_rook.o dchksy_aa.o dchktb.o dchktp.o dchktr.o \
+ dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o dchksy_aa.o dchktb.o dchktp.o dchktr.o \
dchktz.o \
ddrvgt.o ddrvls.o ddrvpb.o \
- ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_aa.o\
+ ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_rk.o ddrvsy_aa.o \
derrgt.o derrlq.o derrls.o \
derrps.o derrql.o derrqp.o derrqr.o \
derrrq.o derrtr.o derrtz.o \
dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \
dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \
drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \
- dspt01.o dsyt01.o dsyt01_rook.o dsyt01_aa.o\
+ dspt01.o dsyt01.o dsyt01_rook.o dsyt01_3.o dsyt01_aa.o\
dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \
dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \
dtrt02.o dtrt03.o dtrt05.o dtrt06.o \
ZLINTST = zchkaa.o \
zchkeq.o zchkgb.o zchkge.o zchkgt.o \
- zchkhe.o zchkhe_rook.o zchkhe_aa.o zchkhp.o zchklq.o zchkpb.o \
+ zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhp.o zchklq.o zchkpb.o \
zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \
- zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \
+ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o zchktb.o \
zchktp.o zchktr.o zchktz.o \
- zdrvgt.o zdrvhe_rook.o zdrvhe_aa.o zdrvhp.o \
+ zdrvgt.o zdrvhe_rook.o zdrvhe_rk.o zdrvhe_aa.o zdrvhp.o \
zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \
- zdrvsp.o zdrvsy_rook.o \
+ zdrvsp.o zdrvsy_rook.o zdrvsy_rk.o \
zerrgt.o zerrlq.o \
zerrls.o zerrps.o zerrql.o zerrqp.o \
zerrqr.o zerrrq.o zerrtr.o zerrtz.o \
zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \
zgerqs.o zget01.o zget02.o \
zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \
- zgtt05.o zhet01.o zhet01_rook.o zhet01_aa.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
+ zgtt05.o zhet01.o zhet01_rook.o zhet01_3.o \
+ zhet01_aa.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \
zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \
zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \
zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \
zqrt12.o zqrt13.o zqrt14.o zqrt15.o zqrt16.o \
zqrt17.o zrqt01.o zrqt02.o zrqt03.o zrzt01.o zrzt02.o \
zsbmv.o zspt01.o \
- zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt02.o zsyt03.o \
+ zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt01_3.o zsyt02.o zsyt03.o \
ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \
ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \
ztrt02.o ztrt03.o ztrt05.o ztrt06.o \
*> _SY: Symmetric indefinite,
*> with partial (Bunch-Kaufman) pivoting
*> _SR: Symmetric indefinite,
-*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> _SK: Symmetric indefinite,
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> ( new storage format for factors:
+*> L and diagonal of D is stored in A,
+*> subdiagonal of D is stored in E )
*> _SP: Symmetric indefinite packed,
*> with partial (Bunch-Kaufman) pivoting
*> _HA: (complex) Hermitian ,
*> _HE: (complex) Hermitian indefinite,
*> with partial (Bunch-Kaufman) pivoting
*> _HR: (complex) Hermitian indefinite,
-*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> _HK: (complex) Hermitian indefinite,
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> ( new storage format for factors:
+*> L and diagonal of D is stored in A,
+*> subdiagonal of D is stored in E )
*> _HP: (complex) Hermitian indefinite packed,
*> with partial (Bunch-Kaufman) pivoting
*> The first character must be one of S, D, C, or Z (C or Z only
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup aux_lin
*
* =====================================================================
SUBROUTINE ALADHD( IOUNIT, PATH )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
- ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN
+ ELSE IF( LSAMEN( 2, P2, 'SR' ) .OR. LSAMEN( 2, P2, 'SK') ) THEN
*
* SR: Symmetric indefinite full,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* with rook (bounded Bunch-Kaufman) pivoting algorithm
+*
+* SK: Symmetric indefinite full,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm,
+* ( new storage format for factors:
+* L and diagonal of D is stored in A,
+* subdiagonal of D is stored in E )
*
WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
*
WRITE( IOUNIT, FMT = 9976 )6
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
- ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN
+ ELSE IF( LSAMEN( 2, P2, 'HR' ) .OR. LSAMEN( 2, P2, 'HK' ) ) THEN
*
* HR: Hermitian indefinite full,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* with rook (bounded Bunch-Kaufman) pivoting algorithm
+*
+* HK: Hermitian indefinite full,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm,
+* ( new storage format for factors:
+* L and diagonal of D is stored in A,
+* subdiagonal of D is stored in E )
*
WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup aux_lin
*
SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
$ N5, IMAT, NFAIL, NERRS, NOUT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
*
ELSE IF( LSAMEN( 2, P2, 'SY' )
$ .OR. LSAMEN( 2, P2, 'SR' )
+ $ .OR. LSAMEN( 2, P2, 'SK' )
$ .OR. LSAMEN( 2, P2, 'HE' )
- $ .OR. LSAMEN( 2, P2, 'HA' )
- $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN
+ $ .OR. LSAMEN( 2, P2, 'HR' )
+ $ .OR. LSAMEN( 2, P2, 'HK' )
+ $ .OR. LSAMEN( 2, P2, 'HA' ) ) THEN
*
* xSY: symmetric indefinite matrices
* with partial (Bunch-Kaufman) pivoting;
* xSR: symmetric indefinite matrices
* with rook (bounded Bunch-Kaufman) pivoting;
+* xSK: symmetric indefinite matrices
+* with rook (bounded Bunch-Kaufman) pivoting,
+* new storage format;
* xHE: Hermitian indefinite matrices
* with partial (Bunch-Kaufman) pivoting.
-* xHA: Hermitian matrices
-* Aasen Algorithm
* xHR: Hermitian indefinite matrices
* with rook (bounded Bunch-Kaufman) pivoting;
+* xHK: Hermitian indefinite matrices
+* with rook (bounded Bunch-Kaufman) pivoting,
+* new storage format;
+* xHA: Hermitian matrices
+* Aasen Algorithm
*
UPLO = OPTS( 1: 1 )
IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
*> _SY: Symmetric indefinite,
*> with partial (Bunch-Kaufman) pivoting
*> _SR: Symmetric indefinite,
-*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> _SK: Symmetric indefinite,
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> ( new storage format for factors:
+*> L and diagonal of D is stored in A,
+*> subdiagonal of D is stored in E )
*> _SP: Symmetric indefinite packed,
*> with partial (Bunch-Kaufman) pivoting
*> _HA: (complex) Hermitian ,
*> with Aasen Algorithm
*> _HE: (complex) Hermitian indefinite,
*> with partial (Bunch-Kaufman) pivoting
-*> _HR: Symmetric indefinite,
-*> with "rook" (bounded Bunch-Kaufman) pivoting
+*> _HR: (complex) Hermitian indefinite,
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> _HK: (complex) Hermitian indefinite,
+*> with rook (bounded Bunch-Kaufman) pivoting
+*> ( new storage format for factors:
+*> L and diagonal of D is stored in A,
+*> subdiagonal of D is stored in E )
*> _HP: (complex) Hermitian indefinite packed,
*> with partial (Bunch-Kaufman) pivoting
*> _TR: Triangular
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup aux_lin
*
* =====================================================================
SUBROUTINE ALAHD( IOUNIT, PATH )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
WRITE( IOUNIT, FMT = 9955 )9
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
- ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN
+ ELSE IF( LSAMEN( 2, P2, 'SR' ) .OR. LSAMEN( 2, P2, 'SK') ) THEN
*
* SR: Symmetric indefinite full,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* with rook (bounded Bunch-Kaufman) pivoting algorithm
+*
+* SK: Symmetric indefinite full,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm,
+* ( new storage format for factors:
+* L and diagonal of D is stored in A,
+* subdiagonal of D is stored in E )
*
WRITE( IOUNIT, FMT = 9892 )PATH, 'Symmetric'
*
WRITE( IOUNIT, FMT = 9955 )9
WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
*
- ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN
+ ELSE IF( LSAMEN( 2, P2, 'HR' ) .OR. LSAMEN( 2, P2, 'HR' ) ) THEN
+*
+* HR: Hermitian indefinite full,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm
*
-* HR: Symmetric indefinite full,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* HK: Hermitian indefinite full,
+* with rook (bounded Bunch-Kaufman) pivoting algorithm,
+* ( new storage format for factors:
+* L and diagonal of D is stored in A,
+* subdiagonal of D is stored in E )
*
WRITE( IOUNIT, FMT = 9892 )PATH, 'Hermitian'
*
*> CPT 12 List types on next line if 0 < NTYPES < 12
*> CHE 10 List types on next line if 0 < NTYPES < 10
*> CHR 10 List types on next line if 0 < NTYPES < 10
+*> CHK 10 List types on next line if 0 < NTYPES < 10
*> CHA 10 List types on next line if 0 < NTYPES < 10
*> CHP 10 List types on next line if 0 < NTYPES < 10
*> CSY 11 List types on next line if 0 < NTYPES < 11
+*> CSK 11 List types on next line if 0 < NTYPES < 11
*> CSR 11 List types on next line if 0 < NTYPES < 11
*> CSP 11 List types on next line if 0 < NTYPES < 11
*> CTR 18 List types on next line if 0 < NTYPES < 18
$ RANKVAL( MAXIN ), PIV( NMAX )
REAL RWORK( 150*NMAX+2*MAXRHS ), S( 2*NMAX )
COMPLEX A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
- $ WORK( NMAX, NMAX+MAXRHS+10 )
+ $ E( NMAX ), WORK( NMAX, NMAX+MAXRHS+10 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE,
- $ CCHKHE_ROOK, CCHKHE_AA, CCHKHP, CCHKLQ, CCHKPB,
- $ CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3, CCHKQL,
- $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK,
- $ CCHKTB, CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE,
- $ CDRVGT, CDRVHE, CDRVHE_ROOK, CDRVHE_AA, CDRVHP,
+ $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKLQ,
+ $ CCHKPB,CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3,
+ $ CCHKQL, CCHKQR, CCHKRQ, CCHKSP, CCHKSY,
+ $ CCHKSY_ROOK, CCHKSY_RK, CCHKTB, CCHKTP,
+ $ CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE,
+ $ CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, CDRVHP,
$ CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP,
- $ CDRVSY, CDRVSY_ROOK, ILAVER, CCHKQRT, CCHKQRTP
-
+ $ CDRVSY, CDRVSY_ROOK, CDRVSY_RK, ILAVER, CCHKQRT,
+ $ CCHKQRTP
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
-* HA: Hermitian matrices,
-* Aasen Algorithm
+* HR: Hermitian indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
- CALL CCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ NSVAL, THRESH, TSTERR, LDA,
- $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
- $ WORK, RWORK, IWORK, NOUT )
+ CALL CCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
- CALL CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
- $ WORK, RWORK, IWORK, NOUT )
+ CALL CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
*
-* HR: Hermitian indefinite matrices,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* HK: Hermitian indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
+* differnet matrix storage format than HR path version.
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
- CALL CCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
- $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
- $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
- $ WORK, RWORK, IWORK, NOUT )
+ CALL CCHKHE_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
- CALL CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
- $ RWORK, IWORK, NOUT )
+ CALL CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
+*
+* HA: Hermitian matrices,
+* Aasen Algorithm
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
+ $ NSVAL, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
* SR: symmetric indefinite matrices,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* with bounded Bunch-Kaufman (rook) pivoting algorithm
*
NTYPES = 11
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* SK: symmetric indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
+* differnet matrix storage format than SR path version.
+*
+ NTYPES = 11
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL CCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
--- /dev/null
+*> \brief \b CCHKHE_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+* X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKHE_RK tests CHETRF_RK, -TRI_3, -TRS_3,
+*> and -CON_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL ONEHALF
+ PARAMETER ( ONEHALF = 0.5E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
+ $ SING_MIN, RCOND, RCONDC, STEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
+ REAL RESULT( NTESTS )
+ COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
+* ..
+* .. External Functions ..
+ REAL CLANGE, CLANHE, SGET06
+ EXTERNAL CLANGE, CLANHE, SGET06
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CGESVD, CGET04,
+ $ CLACPY, CLARHS, CLATB4, CLATMS, CPOT02, CPOT03,
+ $ CHECON_3, CHET01_3, CHETRF_RK, CHETRI_3,
+ $ CHETRS_3, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC CONJG, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'HK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRHE( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'CHETRF_RK'
+ CALL CHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CHETRF_RK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'CHETRF_RK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL CHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'CHETRI_3'
+*
+* Another reason that we need to compute the invesrse
+* is that CPOT03 produces RCONDC which is used later
+* in TEST6 and TEST7.
+*
+ LWORK = (N+NB+1)*(NB+3)
+ CALL CHETRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Check error code from ZHETRI_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CHETRI_3', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a Hermitian matrix times
+* its inverse.
+*
+ CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in U
+*
+ STEMP = CLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ STEMP = CLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in L
+*
+ STEMP = CLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ STEMP = CLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm (condition number)
+* of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 1, 2 ) = E( K )
+ BLOCK( 2, 1 ) = CONJG( BLOCK( 1, 2 ) )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ CDUMMY, 1, CDUMMY, 1,
+ $ WORK, 6, RWORK( 3 ), INFO )
+*
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ STEMP = SING_MAX / SING_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = E( K )
+ BLOCK( 1, 2 ) = CONJG( BLOCK( 2, 1 ) )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ CDUMMY, 1, CDUMMY, 1,
+ $ WORK, 6, RWORK(3), INFO )
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ STEMP = SING_MAX / SING_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+* Begin loop over NRHS values
+*
+*
+*+ TEST 5 ( Using TRS_3)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'CHETRS_3'
+ CALL CHETRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from CHETRS_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CHETRS_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'CHECON_3'
+ CALL CHECON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from CHECON_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CHECON_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = SGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of CCHKHE_RK
+*
+ END
--- /dev/null
+*> \brief \b CCHKSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+* X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CCHKSY_RK tests CSYTRF_RK, -TRI_3, -TRS_3,
+*> and -CON_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL ONEHALF
+ PARAMETER ( ONEHALF = 0.5E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 11 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
+ $ SING_MIN, RCOND, RCONDC, STEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+ COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
+* ..
+* .. External Functions ..
+ REAL CLANGE, CLANSY, SGET06
+ EXTERNAL CLANGE, CLANSY, SGET06
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGESVD, CGET04,
+ $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, CSYT02,
+ $ CSYT03, CSYCON_3, CSYT01_3, CSYTRF_RK,
+ $ CSYTRI_3, CSYTRS_3, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate test matrix A.
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+ ELSE
+*
+* For matrix kind IMAT = 11, generate special block
+* diagonal matrix to test alternate code
+* for the 2 x 2 blocks.
+*
+ CALL CLATSY( UPLO, N, A, LDA, ISEED )
+*
+ END IF
+*
+* End generate test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'CSYTRF_RK'
+ CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CSYTRF_RK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'CSYTRF_RK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'CSYTRI_3'
+*
+* Another reason that we need to compute the invesrse
+* is that CSYT03 produces RCONDC which is used later
+* in TEST6 and TEST7.
+*
+ LWORK = (N+NB+1)*(NB+3)
+ CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Check error code from CSYTRI_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CSYTRI_3', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL CSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ STEMP = CLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ STEMP = CLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ STEMP = CLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ STEMP = CLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm (condition number)
+* of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 1, 2 ) = E( K )
+ BLOCK( 2, 1 ) = BLOCK( 1, 2 )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ CDUMMY, 1, CDUMMY, 1,
+ $ WORK, 6, RWORK( 3 ), INFO )
+*
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ STEMP = SING_MAX / SING_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = E( K )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ CDUMMY, 1, CDUMMY, 1,
+ $ WORK, 6, RWORK(3), INFO )
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ STEMP = SING_MAX / SING_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_3)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'CSYTRS_3'
+ CALL CSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from CSYTRS_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CSYTRS_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'CSYCON_3'
+ CALL CSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from CSYCON_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'CSYCON_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = SGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of CCHKSY_RK
+*
+ END
--- /dev/null
+*> \brief \b CDRVHE_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+* RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CDRVHE_RK tests the driver routines CHESV_RK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ REAL AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ REAL CLANHE
+ EXTERNAL CLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04,
+ $ CLACPY, CLARHS, CLATB4, CLATMS, CHESV_RK,
+ $ CHET01_3, CPOT02, CHETRF_RK, CHETRI_3
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'HK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+*
+* We need to copute the invesrse to compute
+* RCONDC that is used later in TEST3.
+*
+ CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
+ $ WORK, LWORK, INFO )
+ AINVNM = CLANHE( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test CHESV_RK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* CHESV_RK.
+*
+ SRNAMT = 'CHESV_RK'
+ CALL CHESV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CHESV_RK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'CHESV_RK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL CHET01_3( UPLO, N, A, LDA, AFAC, LDA, E,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'CHESV_RK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of CDRVHE_RK
+*
+ END
--- /dev/null
+*> \brief \b CDRVSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+* RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* REAL RWORK( * )
+* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CDRVSY_RK tests the driver routines CSYSV_RK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX array, dimension (NMAX)
+*> \param[out] AINV
+*>
+*> \verbatim
+*> AINV is COMPLEX array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ REAL RWORK( * )
+ COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 11, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ REAL AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ REAL CLANSY
+ EXTERNAL CLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04,
+ $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY,
+ $ CSYSV_RK, CSYT01_3, CSYT02, CSYTRF_RK, CSYTRI_3
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Complex precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Complex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL CERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with CLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with CLATMS.
+*
+ SRNAMT = 'CLATMS'
+ CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from CLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+ ELSE
+*
+* IMAT = NTYPES: Use a special block diagonal matrix to
+* test alternate code for the 2-by-2 blocks.
+*
+ CALL CLATSY( UPLO, N, A, LDA, ISEED )
+ END IF
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+*
+* We need to copute the invesrse to compute
+* RCONDC that is used later in TEST3.
+*
+ CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
+ $ WORK, LWORK, INFO )
+ AINVNM = CLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'CLARHS'
+ CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test CSYSV_RK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* CSYSV_RK.
+*
+ SRNAMT = 'CSYSV_RK'
+ CALL CSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from CSYSV_RK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'CSYSV_RK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'CSYSV_RK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of CDRVSY_RK
+*
+ END
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IP( NMAX )
REAL R( NMAX ), R1( NMAX ), R2( NMAX )
COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2,
- $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRF_AA,
- $ CHETRI, CHETRI_ROOK, CHETRI2, CHETRS,
- $ CHETRS_ROOK, CHETRS_AA, CHKXER, CHPCON, CHPRFS,
- $ CHPTRF, CHPTRI, CHPTRS
+ EXTERNAL ALAESM, CHECON, CSYCON_3, CHECON_ROOK, CHERFS,
+ $ CHETF2, CHETF2_RK, CHETF2_ROOK, CHETRF_AA,
+ $ CHETRF, CHETRF_RK, CHETRF_ROOK, CHETRI,
+ $ CHETRI_3, CHETRI_3X, CHETRI_ROOK, CHETRI2,
+ $ CHETRI2X, CHETRS, CHETRS_3, CHETRS_ROOK,
+ $ CHETRS_AA, CHKXER, CHPCON, CHPRFS, CHPTRF,
+ $ CHPTRI, CHPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
IP( J ) = J
20 CONTINUE
ANRM = 1.0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* CHETRF
*
SRNAMT = 'CHETRF'
INFOT = 4
CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK )
*
* CHETF2
*
CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK )
*
+* CHETRI2X
+*
+ SRNAMT = 'CHETRI2X'
+ INFOT = 1
+ CALL CHETRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK )
+*
* CHETRS
*
SRNAMT = 'CHETRS'
INFOT = 6
CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with "rook"
+* of a Hermitian indefinite matrix with rook
* (bounded Bunch-Kaufman) diagonal pivoting method.
-*
- ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* CHETRF_ROOK
*
INFOT = 4
CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
*
* CHETF2_ROOK
*
INFOT = 6
CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with Aasen's algorithm.
+* of a Hermitian indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* CHETRF_RK
+*
+ SRNAMT = 'CHETRF_RK'
+ INFOT = 1
+ CALL CHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+*
+* CHETF2_RK
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
+ SRNAMT = 'CHETF2_RK'
+ INFOT = 1
+ CALL CHETF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK )
+*
+* CHETRI_3
+*
+ SRNAMT = 'CHETRI_3'
+ INFOT = 1
+ CALL CHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+*
+* CHETRI_3X
+*
+ SRNAMT = 'CHETRI_3X'
+ INFOT = 1
+ CALL CHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK )
+*
+* CHETRS_3
+*
+ SRNAMT = 'CHETRS_3'
+ INFOT = 1
+ CALL CHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+*
+* CHECON_3
+*
+ SRNAMT = 'CHECON_3'
+ INFOT = 1
+ CALL CHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHECON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO)
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with Aasen's algorithm.
*
* CHETRF_AA
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
$ S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2,
- $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI,
- $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK,
- $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS,
- $ CHERFSX
+ EXTERNAL ALAESM, CHECON, CHECON_3, CHECON_ROOK, CHERFS,
+ $ CHETF2, CHETF2_RK, CHETF2_ROOK, CHETRF,
+ $ CHETRF_RK, CHETRF_ROOK, CHETRI, CHETRI_3,
+ $ CHETRI_3X, CHETRI_ROOK, CHETRI2, CHETRI2X,
+ $ CHETRS, CHETRS_3, CHETRS_ROOK, CHKXER, CHPCON,
+ $ CHPRFS, CHPTRF, CHPTRI, CHPTRS, CHERFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- S( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
IP( J ) = J
20 CONTINUE
ANRM = 1.0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* CHETRF
*
SRNAMT = 'CHETRF'
INFOT = 4
CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK )
*
* CHETF2
*
CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK )
*
+* CHETRI2X
+*
+ SRNAMT = 'CHETRI2X'
+ INFOT = 1
+ CALL CHETRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK )
+*
* CHETRS
*
SRNAMT = 'CHETRS'
$ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS,
$ PARAMS, W, R, INFO )
CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with "rook"
+* of a Hermitian indefinite matrix with rook
* (bounded Bunch-Kaufman) diagonal pivoting method.
-*
- ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* CHETRF_ROOK
*
INFOT = 4
CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK )
*
* CHETF2_ROOK
*
INFOT = 6
CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* CHETRF_RK
+*
+ SRNAMT = 'CHETRF_RK'
+ INFOT = 1
+ CALL CHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK )
+*
+* CHETF2_RK
+*
+ SRNAMT = 'CHETF2_RK'
+ INFOT = 1
+ CALL CHETF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK )
+*
+* CHETRI_3
+*
+ SRNAMT = 'CHETRI_3'
+ INFOT = 1
+ CALL CHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK )
+*
+* CHETRI_3X
+*
+ SRNAMT = 'CHETRI_3X'
+ INFOT = 1
+ CALL CHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK )
+*
+* CHETRS_3
+*
+ SRNAMT = 'CHETRS_3'
+ INFOT = 1
+ CALL CHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK )
+*
+* CHECON_3
+*
+ SRNAMT = 'CHECON_3'
+ INFOT = 1
+ CALL CHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CHECON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO)
+ CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
* Test error exits of the routines that use factorization
* of a Hermitian indefinite packed matrix with patrial
* (Bunch-Kaufman) diagonal pivoting method.
-*
- ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
* CHPTRF
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IP( NMAX )
REAL R( NMAX ), R1( NMAX ), R2( NMAX )
COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI,
- $ CSPTRS, CSYCON, CSYCON_ROOK, CSYRFS, CSYTF2,
- $ CSYTF2_ROOK, CSYTRF, CSYTRF_ROOK, CSYTRI,
- $ CSYTRI_ROOK, CSYTRI2, CSYTRS, CSYTRS_ROOK
+ $ CSPTRS, CSYCON, CSYCON_3, CSYCON_ROOK, CSYRFS,
+ $ CSYTF2, CSYTF2_RK, CSYTF2_ROOK, CSYTRF,
+ $ CSYTRF_RK, CSYTRF_ROOK, CSYTRI, CSYTRI_3,
+ $ CSYTRI_3X, CSYTRI_ROOK, CSYTRI2, CSYTRI2X,
+ $ CSYTRS, CSYTRS_3, CSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
+ B( J ) = 0.E0
+ E( J ) = 0.E0
+ R1( J ) = 0.E0
+ R2( J ) = 0.E0
+ W( J ) = 0.E0
+ X( J ) = 0.E0
IP( J ) = J
20 CONTINUE
ANRM = 1.0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* CSYTRF
*
SRNAMT = 'CSYTRF'
INFOT = 4
CALL CSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK )
*
* CSYTF2
*
CALL CSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'CSYTRI2', INFOT, NOUT, LERR, OK )
*
+* CSYTRI2X
+*
+ SRNAMT = 'CSYTRI2X'
+ INFOT = 1
+ CALL CSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* CSYTRS
*
SRNAMT = 'CSYTRS'
INFOT = 6
CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK )
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with "rook"
-* (bounded Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
* CSYTRF_ROOK
*
SRNAMT = 'CSYTRF_ROOK'
INFOT = 4
CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* CSYTF2_ROOK
*
CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* CSYTRF_RK
+*
+ SRNAMT = 'CSYTRF_RK'
+ INFOT = 1
+ CALL CSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* CSYTF2_RK
+*
+ SRNAMT = 'CSYTF2_RK'
+ INFOT = 1
+ CALL CSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* CSYTRI_3
+*
+ SRNAMT = 'CSYTRI_3'
+ INFOT = 1
+ CALL CSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* CSYTRI_3X
+*
+ SRNAMT = 'CSYTRI_3X'
+ INFOT = 1
+ CALL CSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* CSYTRS_3
+*
+ SRNAMT = 'CSYTRS_3'
+ INFOT = 1
+ CALL CSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* CSYCON_3
+*
+ SRNAMT = 'CSYCON_3'
+ INFOT = 1
+ CALL CSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO)
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* CSPTRF
*
SRNAMT = 'CSPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
$ S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- S( J ) = 0.
+ B( J ) = 0.E0
+ E( J ) = 0.E0
+ R1( J ) = 0.E0
+ R2( J ) = 0.E0
+ W( J ) = 0.E0
+ X( J ) = 0.E0
IP( J ) = J
20 CONTINUE
ANRM = 1.0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
-*
+
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* CSYTRF
*
SRNAMT = 'CSYTRF'
INFOT = 4
CALL CSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK )
*
* CSYTF2
*
CALL CSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'CSYTRI2', INFOT, NOUT, LERR, OK )
*
+* CSYTRI2X
+*
+ SRNAMT = 'CSYTRI2X'
+ INFOT = 1
+ CALL CSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* CSYTRS
*
SRNAMT = 'CSYTRS'
INFOT = 6
CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK )
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with "rook"
-* (bounded Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
* CSYTRF_ROOK
*
SRNAMT = 'CSYTRF_ROOK'
INFOT = 4
CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* CSYTF2_ROOK
*
CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK )
*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* CSYTRF_RK
+*
+ SRNAMT = 'CSYTRF_RK'
+ INFOT = 1
+ CALL CSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* CSYTF2_RK
+*
+ SRNAMT = 'CSYTF2_RK'
+ INFOT = 1
+ CALL CSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* CSYTRI_3
+*
+ SRNAMT = 'CSYTRI_3'
+ INFOT = 1
+ CALL CSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* CSYTRI_3X
+*
+ SRNAMT = 'CSYTRI_3X'
+ INFOT = 1
+ CALL CSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* CSYTRS_3
+*
+ SRNAMT = 'CSYTRS_3'
+ INFOT = 1
+ CALL CSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* CSYCON_3
+*
+ SRNAMT = 'CSYCON_3'
+ INFOT = 1
+ CALL CSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL CSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL CSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO)
+ CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* CSPTRF
*
SRNAMT = 'CSPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
REAL C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
$ RF( NMAX ), RW( NMAX )
COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX,
- $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV,
- $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV,
- $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV,
- $ CSYSV_AA, CSYSV_ROOK, CSYSVX
+ $ CHESV, CHESV_RK ,CHESV_ROOK, CHESVX, CHKXER,
+ $ CHPSV, CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX,
+ $ CPPSV, CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX,
+ $ CSYSV, CSYSV_AA, CSYSV_RK, CSYSV_ROOK,
+ $ CSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- C( J ) = 0.
- R( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
+ C( J ) = 0.E+0
+ R( J ) = 0.E+0
IP( J ) = J
20 CONTINUE
EQ = ' '
INFOT = 8
CALL CHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK )
*
* CHESVX
*
$ RCOND, R1, R2, W, 3, RW, INFO )
CALL CHKXER( 'CHESVX', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
-*
-* CHESV_AA
-*
- SRNAMT = 'CHESV_AA'
- INFOT = 1
- CALL CHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL CHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL CHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 8
- CALL CHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
-*
-
ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* CHESV_ROOK
*
- SRNAMT = 'CHESV_ROOK'
- INFOT = 1
- CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
- INFOT = 8
- CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ SRNAMT = 'CHESV_ROOK'
+ INFOT = 1
+ CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
+*
+* CHESV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'CHESV_RK'
+ INFOT = 1
+ CALL CHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
+*
+* CHESV_AASEN
+*
+ SRNAMT = 'CHESV_AA'
+ INFOT = 1
+ CALL CHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
INFOT = 8
CALL CSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK )
*
* CSYSVX
*
INFOT = 8
CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* CSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'CSYSV_RK'
+ INFOT = 1
+ CALL CSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup complex_lin
*
* =====================================================================
SUBROUTINE CERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
$ RF( NMAX ), RW( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX,
- $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV,
- $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV,
- $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV,
- $ CSYSV_ROOK, CSYSVX, CGESVXX, CPOSVXX, CSYSVXX,
- $ CHESVXX, CGBSVXX
+ $ CHESV, CHESV_RK, CHESV_ROOK, CHESVX, CHKXER,
+ $ CHPSV, CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX,
+ $ CPPSV, CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX,
+ $ CSYSV, CSYSV_RK, CSYSV_ROOK, CSYSVX, CGESVXX,
+ $ CPOSVXX, CSYSVXX, CHESVXX, CGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- C( J ) = 0.
- R( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
+ C( J ) = 0.E+0
+ R( J ) = 0.E+0
IP( J ) = J
20 CONTINUE
EQ = ' '
INFOT = 8
CALL CHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK )
*
* CHESVX
*
*
* CHESV_ROOK
*
- SRNAMT = 'CHESV_ROOK'
- INFOT = 1
- CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
- INFOT = 8
- CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ SRNAMT = 'CHESV_ROOK'
+ INFOT = 1
+ CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
+*
+* CHESV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'CHESV_RK'
+ INFOT = 1
+ CALL CHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
INFOT = 8
CALL CSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK )
*
* CSYSVX
*
INFOT = 8
CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* CSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'CSYSV_RK'
+ INFOT = 1
+ CALL CSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL CSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL CSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL CSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL CSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
--- /dev/null
+*> \brief \b CHET01_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+* LDC, RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* REAL RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL RWORK( * )
+* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CHET01_3 reconstructs a Hermitian indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization computed by CHETRF_RK
+*> (or CHETRF_BK) and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The original Hermitian matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (LDAFAC,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by CHETRF_RK and CHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC.
+*> LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from CHETRF_RK (or CHETRF_BK).
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is REAL
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ REAL RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL RWORK( * )
+ COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ E( * )
+* ..
+*
+* =====================================================================
+*
+* .. 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 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL CLANHE, SLAMCH
+ EXTERNAL LSAME, CLANHE, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLASET, CLAVHE_ROOK, CSYCONVF_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC AIMAG, REAL
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* a) Revert to multiplyers of L
+*
+ CALL CSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+* 1) Determine EPS and the norm of A.
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Check the imaginary parts of the diagonal elements and return with
+* an error code if any are nonzero.
+*
+ DO J = 1, N
+ IF( AIMAG( AFAC( J, J ) ).NE.ZERO ) THEN
+ RESID = ONE / EPS
+ RETURN
+ END IF
+ END DO
+*
+* 2) Initialize C to the identity matrix.
+*
+ CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* 3) Call CLAVHE_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL CLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 4) Call ZLAVHE_RK again to multiply by U (or L ).
+*
+ CALL CLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 5) Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO J = 1, N
+ DO I = 1, J - 1
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ C( J, J ) = C( J, J ) - REAL( A( J, J ) )
+ END DO
+ ELSE
+ DO J = 1, N
+ C( J, J ) = C( J, J ) - REAL( A( J, J ) )
+ DO I = J + 1, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ END IF
+*
+* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = CLANHE( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS
+ END IF
+*
+* b) Convert to factor of L (or U)
+*
+ CALL CSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+ RETURN
+*
+* End of CHET01_3
+*
+ END
--- /dev/null
+*> \brief \b CSYT01_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+* LDC, RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* REAL RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* REAL RWORK( * )
+* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> CSYT01_3 reconstructs a symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization computed by CSYTRF_RK
+*> (or CSYTRF_BK) and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX array, dimension (LDA,N)
+*> The original symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX array, dimension (LDAFAC,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by CSYTRF_RK and CSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC.
+*> LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from CSYTRF_RK (or CSYTRF_BK).
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is REAL
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex_lin
+*
+* =====================================================================
+ SUBROUTINE CSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ REAL RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL RWORK( * )
+ COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ E( * )
+* ..
+*
+* =====================================================================
+*
+* .. 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 ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, CLANSY
+ EXTERNAL LSAME, SLAMCH, CLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLASET, CLAVSY_ROOK, CSYCONVF_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* a) Revert to multiplyers of L
+*
+ CALL CSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+* 1) Determine EPS and the norm of A.
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* 2) Initialize C to the identity matrix.
+*
+ CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL CLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 4) Call ZLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL CLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 5) Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO J = 1, N
+ DO I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ ELSE
+ DO J = 1, N
+ DO I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ END IF
+*
+* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = CLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
+ END IF
+
+*
+* b) Convert to factor of L (or U)
+*
+ CALL CSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+ RETURN
+*
+* End of CSYT01_3
+*
+ END
*> DPP 9 List types on next line if 0 < NTYPES < 9
*> DPB 8 List types on next line if 0 < NTYPES < 8
*> DPT 12 List types on next line if 0 < NTYPES < 12
-*> DSA 10 List types on next line if 0 < NTYPES < 10
*> DSY 10 List types on next line if 0 < NTYPES < 10
*> DSR 10 List types on next line if 0 < NTYPES < 10
+*> DSK 10 List types on next line if 0 < NTYPES < 10
+*> DSA 10 List types on next line if 0 < NTYPES < 10
*> DSP 10 List types on next line if 0 < NTYPES < 10
*> DTR 18 List types on next line if 0 < NTYPES < 18
*> DTP 18 List types on next line if 0 < NTYPES < 18
$ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
$ RANKVAL( MAXIN ), PIV( NMAX )
DOUBLE PRECISION A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
- $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ),
- $ WORK( NMAX, NMAX+MAXRHS+30 )
+ $ E( NMAX ), RWORK( 5*NMAX+2*MAXRHS ),
+ $ S( 2*NMAX ), WORK( NMAX, NMAX+MAXRHS+30 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
$ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3,
$ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY,
- $ DCHKSY_ROOK, DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR,
- $ DCHKTZ, DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB,
- $ DDRVPO, DDRVPP, DDRVPT, DDRVSP, DDRVSY,
- $ DDRVSY_ROOK, DDRVSY_AA, ILAVER, DCHKQRT,
+ $ DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, DCHKTB,
+ $ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE,
+ $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP,
+ $ DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK,
+ $ DDRVSY_AA, ILAVER, DCHKQRT,
$ DCHKQRTP, DCHKLQTP, DCHKTSQR, DCHKLQT
* ..
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
-* SR: symmetric indefinite matrices with Rook pivoting,
-* with rook (bounded Bunch-Kaufman) pivoting algorithm
+* SR: symmetric indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* SK: symmetric indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
+* differnet matrix storage format than SR path version.
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
*
-* SY: symmetric indefinite matrices,
+* SA: symmetric indefinite matrices,
* with partial (Aasen's) pivoting algorithm
*
NTYPES = 10
--- /dev/null
+*> \brief \b DCHKSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+* X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* DOUBLE PRECISION A( * ), AFAC( * ), E( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DCHKSY_RK tests DSYTRF_RK, -TRI_3, -TRS_3, and -CON_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX),
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX),
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX),
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK,
+ $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN,
+ $ NT
+ DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
+ $ SING_MIN, RCOND, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION BLOCK( 2, 2 ), DDUMMY( 1 ), RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DGET06, DLANGE, DLANSY
+ EXTERNAL DGET06, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGESVD, DGET04,
+ $ DLACPY, DLARHS, DLATB4, DLATMS, DPOT02, DPOT03,
+ $ DSYCON_3, DSYT01_3, DSYTRF_RK, DSYTRI_3,
+ $ DSYTRS_3, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Double precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL DERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with DLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with DLATMS.
+*
+ SRNAMT = 'DLATMS'
+ CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from DLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'DSYTRF_RK'
+ CALL DSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from DSYTRF_RK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'DSYTRF_RK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL DSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'DSYTRI_3'
+*
+* Another reason that we need to compute the invesrse
+* is that DPOT03 produces RCONDC which is used later
+* in TEST6 and TEST7.
+*
+ LWORK = (N+NB+1)*(NB+3)
+ CALL DSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Check error code from DSYTRI_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DSYTRI_3', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ONE / ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ DTEMP = DLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ DTEMP = DLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ DTEMP = DLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ DTEMP = DLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*+ TEST 4
+* Compute largest 2-Norm (condition number)
+* of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ONE+ALPHA ) / ( ONE-ALPHA )
+ CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 1, 2 ) = E( K )
+ BLOCK( 2, 1 ) = BLOCK( 1, 2 )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL DGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ DDUMMY, 1, DDUMMY, 1,
+ $ WORK, 10, INFO )
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ DTEMP = SING_MAX / SING_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = E( K )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL DGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ DDUMMY, 1, DDUMMY, 1,
+ $ WORK, 10, INFO )
+*
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ DTEMP = SING_MAX / SING_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_3)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'DLARHS'
+ CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'DSYTRS_3'
+ CALL DSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from DSYTRS_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DSYTRS_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'DSYCON_3'
+ CALL DSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
+ $ RCOND, WORK, IWORK( N+1 ), INFO )
+*
+* Check error code from DSYCON_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DSYCON_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare to values of RCOND
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 ) UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of DCHKSY_RK
+*
+ END
--- /dev/null
+*> \brief \b DDRVSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+* $ RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> DDRVSY_RK tests the driver routines DSYSV_RK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLANSY
+ EXTERNAL DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY,
+ $ DLARHS, DLATB4, DLATMS, DPOT02, DSYSV_RK,
+ $ DSYT01_3, DSYTRF_RK, DSYTRI_3, XLAENV
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Double precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL DERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with DLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with DLATMS.
+*
+ SRNAMT = 'DLATMS'
+ CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from DLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of the
+* matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IOFF = 0
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+ CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL DSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+*
+* We need to copute the invesrse to compute
+* RCONDC that is used later in TEST3.
+*
+ CALL DSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
+ $ WORK, LWORK, INFO )
+ AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'DLARHS'
+ CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test DSYSV_RK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* DSYSV_RK.
+*
+ SRNAMT = 'DSYSV_RK'
+ CALL DSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from DSYSV_RK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'DSYSV_RK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL DSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'DSYSV_RK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of DDRVSY_RK
+*
+ END
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX )
+ $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ),
+ $ X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI,
- $ DSPTRS, DSYCON, DSYCON_ROOK, DSYRFS, DSYTF2,
- $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRF_AA,
- $ DSYTRI, DSYTRI_ROOK, DSYTRI2, DSYTRS,
- $ DSYTRS_ROOK, DSYTRS_AA
+ $ DSPTRS, DSYCON, DSYCON_3, DSYCON_ROOK, DSYRFS,
+ $ DSYTF2, DSYTF2_RK, DSYTF2_ROOK, DSYTRF,
+ $ DSYTRF_RK, DSYTRF_ROOK, DSYTRF_AA, DSYTRI,
+ $ DSYTRI_3, DSYTRI_3X, DSYTRI_ROOK, DSYTRI2,
+ $ DSYTRI2X, DSYTRS, DSYTRS_3, DSYTRS_ROOK,
+ $ DSYTRS_AA
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
INFOT = 4
CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
*
* DSYTF2
*
CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO )
CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK )
*
+* DSYTRI2X
+*
+ SRNAMT = 'DSYTRI2X'
+ INFOT = 1
+ CALL DSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* DSYTRS
*
SRNAMT = 'DSYTRS'
INFOT = 4
CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* DSYTF2_ROOK
*
INFOT = 6
CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO)
CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* DSYTRF_RK
+*
+ SRNAMT = 'DSYTRF_RK'
+ INFOT = 1
+ CALL DSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRF_RK( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* DSYTF2_RK
+*
+ SRNAMT = 'DSYTF2_RK'
+ INFOT = 1
+ CALL DSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* DSYTRI_3
+*
+ SRNAMT = 'DSYTRI_3'
+ INFOT = 1
+ CALL DSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* DSYTRI_3X
+*
+ SRNAMT = 'DSYTRI_3X'
+ INFOT = 1
+ CALL DSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* DSYTRS_3
+*
+ SRNAMT = 'DSYTRS_3'
+ INFOT = 1
+ CALL DSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* DSYCON_3
+*
+ SRNAMT = 'DSYCON_3'
+ INFOT = 1
+ CALL DSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, IW,
+ $ INFO)
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
*
INFOT = 8
CALL DSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK )
+*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* Test error exits of the routines that use factorization
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ),
- $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
+ $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ),
+ $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
* ..
* .. External Functions ..
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, DSPCON, DSYCON_ROOK, DSPRFS,
- $ DSPTRF, DSPTRI, DSPTRS, DSYCON, DSYRFS, DSYTF2,
- $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI,
- $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK,
- $ DSYRFSX
+ EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI,
+ $ DSPTRS, DSYCON, DSYCON_3, DSYCON_ROOK, DSYRFS,
+ $ DSYTF2, DSYTF2_RK, DSYTF2_ROOK, DSYTRF,
+ $ DSYTRF_RK, DSYTRF_ROOK, DSYTRI, DSYTRI_3,
+ $ DSYTRI_3X, DSYTRI_ROOK, DSYTRI2, DSYTRI2X,
+ $ DSYTRS, DSYTRS_3, DSYTRS_ROOK, DSYRFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
INFOT = 4
CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK )
*
* DSYTF2
*
CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO )
CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK )
*
+* DSYTRI2X
+*
+ SRNAMT = 'DSYTRI2X'
+ INFOT = 1
+ CALL DSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* DSYTRS
*
SRNAMT = 'DSYTRS'
INFOT = 4
CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* DSYTF2_ROOK
*
INFOT = 6
CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO)
CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* DSYTRF_RK
+*
+ SRNAMT = 'DSYTRF_RK'
+ INFOT = 1
+ CALL DSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRF_RK( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* DSYTF2_RK
+*
+ SRNAMT = 'DSYTF2_RK'
+ INFOT = 1
+ CALL DSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* DSYTRI_3
+*
+ SRNAMT = 'DSYTRI_3'
+ INFOT = 1
+ CALL DSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* DSYTRI_3X
+*
+ SRNAMT = 'DSYTRI_3X'
+ INFOT = 1
+ CALL DSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* DSYTRS_3
+*
+ SRNAMT = 'DSYTRS_3'
+ INFOT = 1
+ CALL DSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* DSYCON_3
+*
+ SRNAMT = 'DSYCON_3'
+ INFOT = 1
+ CALL DSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, IW,
+ $ INFO)
+ CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2016
*
*> \ingroup double_lin
*
* =====================================================================
SUBROUTINE DERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ),
+ $ R2( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV,
$ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV,
$ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV,
- $ DSYSV_AA, DSYSV_ROOK, DSYSVX
+ $ DSYSV_AA, DSYSV_RK, DSYSV_ROOK, DSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
- B( J ) = 0.D0
- R1( J ) = 0.D0
- R2( J ) = 0.D0
- W( J ) = 0.D0
- X( J ) = 0.D0
- C( J ) = 0.D0
- R( J ) = 0.D0
+ B( J ) = 0.D+0
+ E( J ) = 0.D+0
+ R1( J ) = 0.D+0
+ R2( J ) = 0.D+0
+ W( J ) = 0.D+0
+ X( J ) = 0.D+0
+ C( J ) = 0.D+0
+ R( J ) = 0.D+0
IP( J ) = J
20 CONTINUE
EQ = ' '
INFOT = 3
CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
*
* DSYSVX
*
$ RCOND, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
-*
-* DSYSV_AA
-*
- SRNAMT = 'DSYSV_AA'
- INFOT = 1
- CALL DSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL DSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL DSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 8
- CALL DSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
-*
-
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
* DSYSV_ROOK
INFOT = 3
CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYSV_ROOK( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* DSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'DSYSV_RK'
+ INFOT = 1
+ CALL DSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
+*
+* DSYSV_AA
+*
+ SRNAMT = 'DSYSV_AA'
+ INFOT = 1
+ CALL DSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
- $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ),
- $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
+ $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ),
+ $ R2( NMAX ), W( 2*NMAX ), X( NMAX ),
+ $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ),
+ $ PARAMS( 1 )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV,
$ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV,
$ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV,
- $ DSYSVX, DGESVXX, DSYSVXX, DPOSVXX, DGBSVXX
+ $ DSYSV_RK, DSYSV_ROOK, DSYSVX, DGESVXX, DSYSVXX,
+ $ DPOSVXX, DGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = 1.D0 / DBLE( I+J )
AF( I, J ) = 1.D0 / DBLE( I+J )
10 CONTINUE
- B( J ) = 0.D0
- R1( J ) = 0.D0
- R2( J ) = 0.D0
- W( J ) = 0.D0
- X( J ) = 0.D0
- C( J ) = 0.D0
- R( J ) = 0.D0
+ B( J ) = 0.D+0
+ E( J ) = 0.D+0
+ R1( J ) = 0.D+0
+ R2( J ) = 0.D+0
+ W( J ) = 0.D+0
+ X( J ) = 0.D+0
+ C( J ) = 0.D+0
+ R( J ) = 0.D+0
IP( J ) = J
20 CONTINUE
EQ = ' '
INFOT = 3
CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK )
*
* DSYSVX
*
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO )
CALL CHKXER( 'DSYSVXX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
+*
+* DSYSV_ROOK
+*
+ SRNAMT = 'DSYSV_ROOK'
+ INFOT = 1
+ CALL DSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYSV_ROOK( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* DSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'DSYSV_RK'
+ INFOT = 1
+ CALL DSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
--- /dev/null
+*> \brief \b DSYT01_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+* LDC, RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* $ E( * ), RWORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> DSYT01_3 reconstructs a symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization computed by DSYTRF_RK
+*> (or DSYTRF_BK) and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> The original symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by DSYTRF_RK and DSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC.
+*> LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from DSYTRF_RK (or DSYTRF_BK).
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE DSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ E( * ), RWORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASET, DLAVSY_ROOK, DSYCONVF_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* a) Revert to multiplyers of L
+*
+ CALL DSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+* 1) Determine EPS and the norm of A.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* 2) Initialize C to the identity matrix.
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC )
+*
+* 3) Call DLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL DLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 4) Call DLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL DLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 5) Compute the difference C - A.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO J = 1, N
+ DO I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ ELSE
+ DO J = 1, N
+ DO I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ END IF
+*
+* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
+ END IF
+
+*
+* b) Convert to factor of L (or U)
+*
+ CALL DSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+ RETURN
+*
+* End of DSYT01_3
+*
+ END
*> SPT 12 List types on next line if 0 < NTYPES < 12
*> SSY 10 List types on next line if 0 < NTYPES < 10
*> SSR 10 List types on next line if 0 < NTYPES < 10
+*> SSK 10 List types on next line if 0 < NTYPES < 10
+*> SSA 10 List types on next line if 0 < NTYPES < 10
*> SSP 10 List types on next line if 0 < NTYPES < 10
*> STR 18 List types on next line if 0 < NTYPES < 18
*> STP 18 List types on next line if 0 < NTYPES < 18
$ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
$ RANKVAL( MAXIN ), PIV( NMAX )
REAL A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
- $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ),
- $ WORK( NMAX, NMAX+MAXRHS+30 )
+ $ E( NMAX ), RWORK( 5*NMAX+2*MAXRHS ),
+ $ S( 2*NMAX ), WORK( NMAX, NMAX+MAXRHS+30 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ,
$ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3,
$ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY,
- $ SCHKSY_ROOK, SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR,
- $ SCHKTZ, SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB,
- $ SDRVPO, SDRVPP, SDRVPT, SDRVSP, SDRVSY,
- $ SDRVSY_ROOK, SDRVSY_AA, ILAVER, SCHKLQTP,
- $ SCHKQRT, SCHKQRTP
+ $ SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, SCHKTB,
+ $ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT,
+ $ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP,
+ $ SDRVSY, SDRVSY_ROOK, SDRVSY_RK, SDRVSY_AA,
+ $ ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
-* SR: symmetric indefinite matrices with Rook pivoting,
-* with rook (bounded Bunch-Kaufman) pivoting algorithm
+* SR: symmetric indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* SK: symmetric indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
+* differnet matrix storage format than SR path version.
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL SCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
*
-* SY: symmetric indefinite matrices,
+* SA: symmetric indefinite matrices,
* with partial (Aasen's) pivoting algorithm
*
NTYPES = 10
--- /dev/null
+*> \brief \b SCHKSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+* X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SCHKSY_RK tests SSYTRF_RK, -TRI_3, -TRS_3, and -CON_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is REAL array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is REAL array, dimension (NMAX*NSMAX),
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is REAL array, dimension (NMAX*NSMAX),
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is REAL array, dimension (NMAX*NSMAX),
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup double_lin
+*
+* =====================================================================
+ SUBROUTINE SCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK,
+ $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN,
+ $ NT
+ REAL ALPHA, ANORM, CNDNUM, CONST, STEMP, SING_MAX,
+ $ SING_MIN, RCOND, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 )
+ REAL BLOCK( 2, 2 ), SDUMMY( 1 ), RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ REAL SGET06, SLANGE, SLANSY
+ EXTERNAL SGET06, SLANGE, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGESVD, SGET04,
+ $ SLACPY, SLARHS, SLATB4, SLATMS, SPOT02, SPOT03,
+ $ SSYCON_3, SSYT01_3, SSYTRF_RK, SSYTRI_3,
+ $ SSYTRS_3, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Single precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Single precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL SERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with SLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with SLATMS.
+*
+ SRNAMT = 'SLATMS'
+ CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from SLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'SSYTRF_RK'
+ CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from DSYTRF_RK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'SSYTRF_RK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'SSYTRI_3'
+*
+* Another reason that we need to compute the invesrse
+* is that SPOT03 produces RCONDC which is used later
+* in TEST6 and TEST7.
+*
+ LWORK = (N+NB+1)*(NB+3)
+ CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Check error code from SSYTRI_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SSYTRI_3', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ONE / ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ STEMP = SLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ STEMP = SLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ STEMP = SLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ STEMP = SLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = STEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*+ TEST 4
+* Compute largest 2-Norm (condition number)
+* of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ STEMP = ZERO
+*
+ CONST = ( ONE+ALPHA ) / ( ONE-ALPHA )
+ CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 1, 2 ) = E( K )
+ BLOCK( 2, 1 ) = BLOCK( 1, 2 )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL SGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ SDUMMY, 1, SDUMMY, 1,
+ $ WORK, 10, INFO )
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ STEMP = SING_MAX / SING_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = E( K )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL SGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ SDUMMY, 1, SDUMMY, 1,
+ $ WORK, 10, INFO )
+*
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ STEMP = SING_MAX / SING_MIN
+*
+* STEMP should be bounded by CONST
+*
+ STEMP = STEMP - CONST + THRESH
+ IF( STEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = STEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_3)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'SLARHS'
+ CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'SSYTRS_3'
+ CALL SSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from SSYTRS_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SSYTRS_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'SSYCON_3'
+ CALL SSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
+ $ RCOND, WORK, IWORK( N+1 ), INFO )
+*
+* Check error code from DSYCON_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'SSYCON_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare to values of RCOND
+*
+ RESULT( 7 ) = SGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 ) UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of SCHKSY_RK
+*
+ END
--- /dev/null
+*> \brief \b SDRVSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+* $ RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* REAL THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ),
+* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*> SDRVSY_RK tests the driver routines SSYSV_RK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is REAL
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is REAL array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is REAL array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is REAL array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is REAL array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is REAL array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup single_lin
+*
+* =====================================================================
+ SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ REAL THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ REAL AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ REAL RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ REAL SLANSY
+ EXTERNAL SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY,
+ $ SLARHS, SLATB4, SLATMS, SPOT02, SSYSV_RK,
+ $ SSYT01_3, SSYTRF_RK, SSYTRI_3, XLAENV
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Single precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Single precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL SERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with SLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with SLATMS.
+*
+ SRNAMT = 'SLATMS'
+ CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
+ $ INFO )
+*
+* Check error code from SLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
+ $ -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of the
+* matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IOFF = 0
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+ CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+*
+* We need to copute the invesrse to compute
+* RCONDC that is used later in TEST3.
+*
+ CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
+ $ WORK, LWORK, INFO )
+ AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'SLARHS'
+ CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test SSYSV_RK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* SSYSV_RK.
+*
+ SRNAMT = 'SSYSV_RK'
+ CALL SSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from SSYSV_RK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'SSYSV_RK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'SSYSV_RK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of SDRVSY_RK
+*
+ END
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX )
+ $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ),
+ $ X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, SSPCON, SSYCON_ROOK, SSPRFS,
- $ SSPTRF, SSPTRI, SSPTRS, SSYCON, SSYRFS, SSYTF2,
- $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRF_AA,
- $ SSYTRI, SSYTRI_ROOK, SSYTRI2, SSYTRS,
- $ SSYTRS_ROOK, SSYTRS_AA
+ EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI,
+ $ SSPTRS, SSYCON, SSYCON_3, SSYCON_ROOK, SSYRFS,
+ $ SSYTF2_RK, SSYTF2_ROOK, SSYTRF, SSYTRF_RK,
+ $ SSYTRF_ROOK, SSYTRI, SSYTF2, SSYTRI_3,
+ $ SSYTRI_3X, SSYTRI_ROOK, SSYTRF_AA, SSYTRI2,
+ $ SYTRI2X, SSYTRS, SSYTRS_3, SSYTRS_ROOK, SSYTRS_AA
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
IP( J ) = J
IW( J ) = J
20 CONTINUE
INFOT = 4
CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
*
* SSYTF2
*
CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO )
CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK )
*
+* SSYTRI2X
+*
+ SRNAMT = 'SSYTRI2X'
+ INFOT = 1
+ CALL SSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* SSYTRS
*
SRNAMT = 'SSYTRS'
INFOT = 4
CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* SSYTF2_ROOK
*
INFOT = 6
CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) pivoting.
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* SSYTRF_RK
+*
+ SRNAMT = 'SSYTRF_RK'
+ INFOT = 1
+ CALL SSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* SSYTF2_RK
+*
+ SRNAMT = 'SSYTF2_RK'
+ INFOT = 1
+ CALL SSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* SSYTRI_3
+*
+ SRNAMT = 'SSYTRI_3'
+ INFOT = 1
+ CALL SSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* SSYTRI_3X
+*
+ SRNAMT = 'SSYTRI_3X'
+ INFOT = 1
+ CALL SSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* SSYTRS_3
+*
+ SRNAMT = 'SSYTRS_3'
+ INFOT = 1
+ CALL SSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* SSYCON_3
+*
+ SRNAMT = 'SSYCON_3'
+ INFOT = 1
+ CALL SSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, IW,
+ $ INFO)
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
*
INFOT = 8
CALL SSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK )
+*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
+*
* SSPTRF
*
SRNAMT = 'SSPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ),
- $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
+ $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ),
+ $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
* ..
* .. External Functions ..
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI,
- $ SSPTRS, SSYCON, SSYCON_ROOK,SSYRFS, SSYTF2,
- $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI,
- $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK,
- $ SSYRFSX
+ $ SSPTRS, SSYCON, SSYCON_3, SSYCON_ROOK, SSYRFS,
+ $ SSYTF2, SSYTF2_RK, SSYTF2_ROOK, SSYTRF,
+ $ SSYTRF_RK, SSYTRF_ROOK, SSYTRI, SSYTRI_3,
+ $ SSYTRI_3X, SSYTRI_ROOK, SSYTRI2, SSYTRI2X,
+ $ SSYTRS, SSYTRS_3, SSYTRS_ROOK, SSYRFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- S( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
IP( J ) = J
IW( J ) = J
20 CONTINUE
INFOT = 4
CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK )
*
* SSYTF2
*
CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO )
CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK )
*
+* SSYTRI2X
+*
+ SRNAMT = 'SSYTRI2X'
+ INFOT = 1
+ CALL SSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* SSYTRS
*
SRNAMT = 'SSYTRS'
INFOT = 4
CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* SSYTF2_ROOK
*
INFOT = 6
CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO )
CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) pivoting.
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* SSYTRF_RK
+*
+ SRNAMT = 'SSYTRF_RK'
+ INFOT = 1
+ CALL SSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* SSYTF2_RK
+*
+ SRNAMT = 'SSYTF2_RK'
+ INFOT = 1
+ CALL SSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* SSYTRI_3
+*
+ SRNAMT = 'SSYTRI_3'
+ INFOT = 1
+ CALL SSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* SSYTRI_3X
+*
+ SRNAMT = 'SSYTRI_3X'
+ INFOT = 1
+ CALL SSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* SSYTRS_3
+*
+ SRNAMT = 'SSYTRS_3'
+ INFOT = 1
+ CALL SSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* SSYCON_3
+*
+ SRNAMT = 'SSYCON_3'
+ INFOT = 1
+ CALL SSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL SSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW,
+ $ INFO )
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL SSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, IW,
+ $ INFO)
+ CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
+*
* SSPTRF
*
SRNAMT = 'SSPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date April 2012
+*> \date November 2016
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.4.1) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* April 2012
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ),
+ $ R2( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV,
$ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV,
$ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV,
- $ SSYSV_AA, SSYSV_ROOK, SSYSVX
+ $ SSYSV_AA, SSYSV_RK, SSYSV_ROOK, SSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- C( J ) = 0.
- R( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
+ C( J ) = 0.E+0
+ R( J ) = 0.E+0
IP( J ) = J
20 CONTINUE
EQ = ' '
INFOT = 8
CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
*
* SSYSVX
*
$ RCOND, R1, R2, W, 3, IW, INFO )
CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
-*
-* SSYSV_AA
-*
- SRNAMT = 'SSYSV_AA'
- INFOT = 1
- CALL SSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL SSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL SSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 8
- CALL SSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
INFOT = 8
CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* SSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'SSYSV_RK'
+ INFOT = 1
+ CALL SSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN
+*
+* SSYSV_AA
+*
+ SRNAMT = 'SSYSV_AA'
+ INFOT = 1
+ CALL SSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL SSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup single_lin
*
* =====================================================================
SUBROUTINE SERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
* .. Local Arrays ..
INTEGER IP( NMAX ), IW( NMAX )
REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
- $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ),
- $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
+ $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ),
+ $ R2( NMAX ), W( 2*NMAX ), X( NMAX ),
+ $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ),
+ $ PARAMS( 1 )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV,
$ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV,
$ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV,
- $ SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, SPOSVXX,
- $ SGBSVXX
+ $ SSYSV_RK, SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX,
+ $ SPOSVXX, SGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
A( I, J ) = 1. / REAL( I+J )
AF( I, J ) = 1. / REAL( I+J )
10 CONTINUE
- B( J ) = 0.
- R1( J ) = 0.
- R2( J ) = 0.
- W( J ) = 0.
- X( J ) = 0.
- C( J ) = 0.
- R( J ) = 0.
+ B( J ) = 0.E+0
+ E( J ) = 0.E+0
+ R1( J ) = 0.E+0
+ R2( J ) = 0.E+0
+ W( J ) = 0.E+0
+ X( J ) = 0.E+0
+ C( J ) = 0.E+0
+ R( J ) = 0.E+0
IP( J ) = J
20 CONTINUE
EQ = ' '
INFOT = 8
CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK )
*
* SSYSVX
*
$ 1, RCOND, RPVGRW, BERR, N_ERR_BNDS, ERR_BNDS_N,
$ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO )
CALL CHKXER( 'SSYSVXX', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
* SSYSV_ROOK
*
INFOT = 8
CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* SSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'SSYSV_RK'
+ INFOT = 1
+ CALL SSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL SSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL SSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL SSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL SSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
--- /dev/null
+*> \brief \b SSYT01_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+* LDC, RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* $ E( * ), RWORK( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> SSYT01_3 reconstructs a symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization computed by SSYTRF_RK
+*> (or SSYTRF_BK) and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is DOUBLE PRECISION array, dimension (LDA,N)
+*> The original symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by SSYTRF_RK and SSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC.
+*> LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is DOUBLE PRECISION array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from SSYTRF_RK (or SSYTRF_BK).
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is DOUBLE PRECISION array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup single_lin
+*
+* =====================================================================
+ SUBROUTINE SSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ REAL RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ E( * ), RWORK( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSY
+ EXTERNAL LSAME, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASET, SLAVSY_ROOK, SSYCONVF_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* a) Revert to multiplyers of L
+*
+ CALL SSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+* 1) Determine EPS and the norm of A.
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* 2) Initialize C to the identity matrix.
+*
+ CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC )
+*
+* 3) Call SLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL SLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 4) Call SLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL SLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 5) Compute the difference C - A.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO J = 1, N
+ DO I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ ELSE
+ DO J = 1, N
+ DO I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ END IF
+*
+* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS
+ END IF
+
+*
+* b) Convert to factor of L (or U)
+*
+ CALL SSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+ RETURN
+*
+* End of SSYT01_3
+*
+ END
*> ZPB 8 List types on next line if 0 < NTYPES < 8
*> ZPT 12 List types on next line if 0 < NTYPES < 12
*> ZHE 10 List types on next line if 0 < NTYPES < 10
-*> ZHA 10 List types on next line if 0 < NTYPES < 10
*> ZHR 10 List types on next line if 0 < NTYPES < 10
+*> ZHK 10 List types on next line if 0 < NTYPES < 10
+*> ZHA 10 List types on next line if 0 < NTYPES < 10
*> ZHP 10 List types on next line if 0 < NTYPES < 10
*> ZSY 11 List types on next line if 0 < NTYPES < 11
*> ZSR 11 List types on next line if 0 < NTYPES < 11
+*> ZSK 11 List types on next line if 0 < NTYPES < 11
*> ZSP 11 List types on next line if 0 < NTYPES < 11
*> ZTR 18 List types on next line if 0 < NTYPES < 18
*> ZTP 18 List types on next line if 0 < NTYPES < 18
$ RANKVAL( MAXIN ), PIV( NMAX )
DOUBLE PRECISION RWORK( 150*NMAX+2*MAXRHS ), S( 2*NMAX )
COMPLEX*16 A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
- $ WORK( NMAX, NMAX+MAXRHS+10 )
+ $ E( NMAX ), WORK( NMAX, NMAX+MAXRHS+10 )
* ..
* .. External Functions ..
LOGICAL LSAME, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE,
- $ ZCHKHE_ROOK, ZCHKHE_AA, ZCHKHP, ZCHKLQ, ZCHKPB,
- $ ZCHKPO, ZCHKPS, ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL,
- $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK,
- $ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE,
- $ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHE_AA, ZDRVHP,
- $ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP,
- $ ZDRVSY, ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP,
- $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR
+ $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP,
+ $ ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP, ZCHKPT,
+ $ ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY,
+ $ ZCHKSY_ROOK, ZCHKSY_RK, ZCHKTB, ZCHKTP, ZCHKTR,
+ $ ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK,
+ $ ZDRVHE_RK, ZDRVHE_AA, ZDRVHP, ZDRVLS, ZDRVPB,
+ $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, ZDRVSY_ROOK,
+ $ ZDRVSY_RK, ILAVER, ZCHKQRT, ZCHKQRTP, ZCHKLQT,
+ $ ZCHKLQTP, ZCHKTSQR
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
-*
-* HA: Hermitian indefinite matrices,
-* with partial (Aasen's) pivoting algorithm
+* HR: Hermitian indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
- CALL ZCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
- $ NSVAL, THRESH, TSTERR, LDA,
- $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
- $ WORK, RWORK, IWORK, NOUT )
+ CALL ZCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
- CALL ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
- $ WORK, RWORK, IWORK, NOUT )
+ CALL ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
*
- ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
*
-* HR: Hermitian indefinite matrices,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* HK: Hermitian indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
+* differnet matrix storage format than HR path version.
*
NTYPES = 10
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
IF( TSTCHK ) THEN
- CALL ZCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ CALL ZCHKHE_RK ( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
$ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
- $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
- $ WORK, RWORK, IWORK, NOUT )
+ $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
*
IF( TSTDRV ) THEN
- CALL ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
- $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
- $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
- $ RWORK, IWORK, NOUT )
+ CALL ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
+*
+* HA: Hermitian indefinite matrices,
+* with partial (Aasen's) pivoting algorithm
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS,
+ $ NSVAL, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
* SR: symmetric indefinite matrices,
-* with "rook" (bounded Bunch-Kaufman) pivoting algorithm
+* with bounded Bunch-Kaufman (rook) pivoting algorithm
*
NTYPES = 11
CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
ELSE
WRITE( NOUT, FMT = 9988 )PATH
END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* SK: symmetric indefinite matrices,
+* with bounded Bunch-Kaufman (rook) pivoting algorithm,
+* differnet matrix storage format than SR path version.
+*
+ NTYPES = 11
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL ZCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
--- /dev/null
+*> \brief \b ZCHKHE_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
+* XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKHE_RK tests ZHETRF_RK, -TRI_3, -TRS_3,
+*> and -CON_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is CCOMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is CCOMPLEX*16 array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ONEHALF
+ PARAMETER ( ONEHALF = 0.5D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 10 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
+ $ SING_MIN, RCOND, RCONDC, DTEMP
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
+ DOUBLE PRECISION RESULT( NTESTS )
+ COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DGET06, ZLANGE, ZLANHE
+ EXTERNAL DGET06, ZLANGE, ZLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, ZERRHE, ZGESVD, ZGET04,
+ $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZPOT02, ZPOT03,
+ $ ZHECON_3, ZHET01_3, ZHETRF_RK, ZHETRI_3,
+ $ ZHETRS_3, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DCONJG, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'HK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRHE( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from ZLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'ZHETRF_RK'
+ CALL ZHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZHETRF_RK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'ZHETRF_RK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL ZHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'ZHETRI_3'
+*
+* Another reason that we need to compute the invesrse
+* is that ZPOT03 produces RCONDC which is used later
+* in TEST6 and TEST7.
+*
+ LWORK = (N+NB+1)*(NB+3)
+ CALL ZHETRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Check error code from ZHETRI_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZHETRI_3', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a Hermitian matrix times
+* its inverse.
+*
+ CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in U
+*
+ DTEMP = ZLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ DTEMP = ZLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in L
+*
+ DTEMP = ZLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ DTEMP = ZLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm (condition number)
+* of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 1, 2 ) = E( K )
+ BLOCK( 2, 1 ) = DCONJG( BLOCK( 1, 2 ) )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ ZDUMMY, 1, ZDUMMY, 1,
+ $ WORK, 6, RWORK( 3 ), INFO )
+*
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ DTEMP = SING_MAX / SING_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = E( K )
+ BLOCK( 1, 2 ) = DCONJG( BLOCK( 2, 1 ) )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ ZDUMMY, 1, ZDUMMY, 1,
+ $ WORK, 6, RWORK(3), INFO )
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ DTEMP = SING_MAX / SING_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+* Begin loop over NRHS values
+*
+*
+*+ TEST 5 ( Using TRS_3)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'ZHETRS_3'
+ CALL ZHETRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from ZHETRS_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZHETRS_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'ZHECON_3'
+ CALL ZHECON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from ZHECON_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZHECON_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of ZCHKHE_RK
+*
+ END
--- /dev/null
+*> \brief \b ZCHKSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+* X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NNB, NNS, NOUT
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZCHKSY_RK tests ZSYTRF_RK, -TRI_3, -TRS_3,
+*> and -CON_3.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NNB
+*> \verbatim
+*> NNB is INTEGER
+*> The number of values of NB contained in the vector NBVAL.
+*> \endverbatim
+*>
+*> \param[in] NBVAL
+*> \verbatim
+*> NBVAL is INTEGER array, dimension (NBVAL)
+*> The values of the blocksize NB.
+*> \endverbatim
+*>
+*> \param[in] NNS
+*> \verbatim
+*> NNS is INTEGER
+*> The number of values of NRHS contained in the vector NSVAL.
+*> \endverbatim
+*>
+*> \param[in] NSVAL
+*> \verbatim
+*> NSVAL is INTEGER array, dimension (NNS)
+*> The values of the number of right hand sides NRHS.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> where NSMAX is the largest entry in NSVAL.
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (2*NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
+ $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ONEHALF
+ PARAMETER ( ONEHALF = 0.5D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+ COMPLEX*16 CZERO
+ PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 11 )
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, TYPE, UPLO, XTYPE
+ CHARACTER*3 PATH, MATPATH
+ INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
+ $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
+ $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
+ $ NRUN, NT
+ DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
+ $ SING_MIN, RCOND, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+ COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DGET06, ZLANGE, ZLANSY
+ EXTERNAL DGET06, ZLANGE, ZLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGESVD, ZGET04,
+ $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZSYT02,
+ $ ZSYT03, ZSYCON_3, ZSYT01_3, ZSYTRF_RK,
+ $ ZSYTRI_3, ZSYTRS_3, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRSY( PATH, NOUT )
+ INFOT = 0
+*
+* Set the minimum block size for which the block routine should
+* be used, which will be later returned by ILAENV
+*
+ CALL XLAENV( 2, 2 )
+*
+* Do for each value of N in NVAL
+*
+ DO 270 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ IZERO = 0
+*
+* Do for each value of matrix type IMAT
+*
+ DO 260 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 260
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 260
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 250 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate test matrix A.
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from ZLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+*
+* Skip all tests for this generated matrix
+*
+ GO TO 250
+ END IF
+*
+* For matrix types 3-6, zero one or more rows and
+* columns of the matrix to test that INFO is returned
+* correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = CZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = CZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = CZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = CZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the last IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = CZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+ ELSE
+*
+* For matrix kind IMAT = 11, generate special block
+* diagonal matrix to test alternate code
+* for the 2 x 2 blocks.
+*
+ CALL ZLATSY( UPLO, N, A, LDA, ISEED )
+*
+ END IF
+*
+* End generate test matrix A.
+*
+*
+* Do for each value of NB in NBVAL
+*
+ DO 240 INB = 1, NNB
+*
+* Set the optimal blocksize, which will be later
+* returned by ILAENV.
+*
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Copy the test matrix A into matrix AFAC which
+* will be factorized in place. This is needed to
+* preserve the test matrix A for subsequent tests.
+*
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+*
+* Compute the L*D*L**T or U*D*U**T factorization of the
+* matrix. IWORK stores details of the interchanges and
+* the block structure of D. AINV is a work array for
+* block factorization, LWORK is the length of AINV.
+*
+ LWORK = MAX( 2, NB )*LDA
+ SRNAMT = 'ZSYTRF_RK'
+ CALL ZSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZSYTRF_RK and handle error.
+*
+ IF( INFO.NE.K)
+ $ CALL ALAERH( PATH, 'ZSYTRF_RK', INFO, K,
+ $ UPLO, N, N, -1, -1, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Set the condition estimate flag if the INFO is not 0.
+*
+ IF( INFO.NE.0 ) THEN
+ TRFCON = .TRUE.
+ ELSE
+ TRFCON = .FALSE.
+ END IF
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute residual.
+*
+ CALL ZSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK,
+ $ AINV, LDA, RWORK, RESULT( 1 ) )
+ NT = 1
+*
+*+ TEST 2
+* Form the inverse and compute the residual,
+* if the factorization was competed without INFO > 0
+* (i.e. there is no zero rows and columns).
+* Do it only for the first block size.
+*
+ IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ SRNAMT = 'ZSYTRI_3'
+*
+* Another reason that we need to compute the invesrse
+* is that ZSYT03 produces RCONDC which is used later
+* in TEST6 and TEST7.
+*
+ LWORK = (N+NB+1)*(NB+3)
+ CALL ZSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Check error code from ZSYTRI_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZSYTRI_3', INFO, -1,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the residual for a symmetric matrix times
+* its inverse.
+*
+ CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
+ $ RWORK, RCONDC, RESULT( 2 ) )
+ NT = 2
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+*
+*+ TEST 3
+* Compute largest element in U or L
+*
+ RESULT( 3 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) /
+ $ ( ONE-ALPHA )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Compute largest element in U
+*
+ K = N
+ 120 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 130
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in U
+*
+ DTEMP = ZLANGE( 'M', K-1, 1,
+ $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k-1 in U
+*
+ DTEMP = ZLANGE( 'M', K-2, 2,
+ $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
+ K = K - 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K - 1
+*
+ GO TO 120
+ 130 CONTINUE
+*
+ ELSE
+*
+* Compute largest element in L
+*
+ K = 1
+ 140 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 150
+*
+ IF( IWORK( K ).GT.ZERO ) THEN
+*
+* Get max absolute value from elements
+* in column k in in L
+*
+ DTEMP = ZLANGE( 'M', N-K, 1,
+ $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
+ ELSE
+*
+* Get max absolute value from elements
+* in columns k and k+1 in L
+*
+ DTEMP = ZLANGE( 'M', N-K-1, 2,
+ $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
+ K = K + 1
+*
+ END IF
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 3 ) )
+ $ RESULT( 3 ) = DTEMP
+*
+ K = K + 1
+*
+ GO TO 140
+ 150 CONTINUE
+ END IF
+*
+*
+*+ TEST 4
+* Compute largest 2-Norm (condition number)
+* of 2-by-2 diag blocks
+*
+ RESULT( 4 ) = ZERO
+ DTEMP = ZERO
+*
+ CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )*
+ $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Loop backward for UPLO = 'U'
+*
+ K = N
+ 160 CONTINUE
+ IF( K.LE.1 )
+ $ GO TO 170
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
+ BLOCK( 1, 2 ) = E( K )
+ BLOCK( 2, 1 ) = BLOCK( 1, 2 )
+ BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
+*
+ CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ ZDUMMY, 1, ZDUMMY, 1,
+ $ WORK, 6, RWORK( 3 ), INFO )
+*
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ DTEMP = SING_MAX / SING_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K - 1
+*
+ END IF
+*
+ K = K - 1
+*
+ GO TO 160
+ 170 CONTINUE
+*
+ ELSE
+*
+* Loop forward for UPLO = 'L'
+*
+ K = 1
+ 180 CONTINUE
+ IF( K.GE.N )
+ $ GO TO 190
+*
+ IF( IWORK( K ).LT.ZERO ) THEN
+*
+* Get the two singular values
+* (real and non-negative) of a 2-by-2 block,
+* store them in RWORK array
+*
+ BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
+ BLOCK( 2, 1 ) = E( K )
+ BLOCK( 1, 2 ) = BLOCK( 2, 1 )
+ BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
+*
+ CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK,
+ $ ZDUMMY, 1, ZDUMMY, 1,
+ $ WORK, 6, RWORK(3), INFO )
+*
+ SING_MAX = RWORK( 1 )
+ SING_MIN = RWORK( 2 )
+*
+ DTEMP = SING_MAX / SING_MIN
+*
+* DTEMP should be bounded by CONST
+*
+ DTEMP = DTEMP - CONST + THRESH
+ IF( DTEMP.GT.RESULT( 4 ) )
+ $ RESULT( 4 ) = DTEMP
+ K = K + 1
+*
+ END IF
+*
+ K = K + 1
+*
+ GO TO 180
+ 190 CONTINUE
+ END IF
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 200 K = 3, 4
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 200 CONTINUE
+ NRUN = NRUN + 2
+*
+* Skip the other tests if this is not the first block
+* size.
+*
+ IF( INB.GT.1 )
+ $ GO TO 240
+*
+* Do only the condition estimate if INFO is not 0.
+*
+ IF( TRFCON ) THEN
+ RCONDC = ZERO
+ GO TO 230
+ END IF
+*
+* Do for each value of NRHS in NSVAL.
+*
+ DO 220 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+*
+*+ TEST 5 ( Using TRS_3)
+* Solve and compute residual for A * X = B.
+*
+* Choose a set of NRHS random solution vectors
+* stored in XACT and set up the right hand side B
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
+ $ KL, KU, NRHS, A, LDA, XACT, LDA,
+ $ B, LDA, ISEED, INFO )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+ SRNAMT = 'ZSYTRS_3'
+ CALL ZSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, INFO )
+*
+* Check error code from ZSYTRS_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZSYTRS_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, NRHS, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+*
+* Compute the residual for the solution
+*
+ CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 5 ) )
+*
+*+ TEST 6
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 6 ) )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 210 K = 5, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS,
+ $ IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 210 CONTINUE
+ NRUN = NRUN + 2
+*
+* End do for each value of NRHS in NSVAL.
+*
+ 220 CONTINUE
+*
+*+ TEST 7
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 230 CONTINUE
+ ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
+ SRNAMT = 'ZSYCON_3'
+ CALL ZSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM,
+ $ RCOND, WORK, INFO )
+*
+* Check error code from ZSYCON_3 and handle error.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'ZSYCON_3', INFO, 0,
+ $ UPLO, N, N, -1, -1, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+* Compute the test ratio to compare values of RCOND
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
+ $ RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 240 CONTINUE
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ',
+ $ I2, ', test ', I2, ', ratio =', G12.5 )
+ 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
+ $ I2, ', test(', I2, ') =', G12.5 )
+ 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
+ $ ', test(', I2, ') =', G12.5 )
+ RETURN
+*
+* End of ZCHKSY_RK
+*
+ END
--- /dev/null
+*> \brief \b ZDRVHE_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+* RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDRVHE_RK tests the driver routines ZHESV_RK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (NMAX)
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 10, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION ZLANHE
+ EXTERNAL ZLANHE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX,
+ $ ZGET04, ZLACPY, ZLARHS, ZLATB4, ZLATMS,
+ $ ZHESV_RK, ZHET01_3, ZPOT02, ZHETRF_RK, ZHETRI_3
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'HK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'HE'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from ZLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+*
+* End generate the test matrix A.
+*
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+*
+* We need to copute the invesrse to compute
+* RCONDC that is used later in TEST3.
+*
+ CALL ZHETRI_3( UPLO, N, AINV, LDA, E, IWORK,
+ $ WORK, LWORK, INFO )
+ AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test ZHESV_RK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* ZHESV_RK.
+*
+ SRNAMT = 'ZHESV_RK'
+ CALL ZHESV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZHESV_RK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'ZHESV_RK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL ZHET01_3( UPLO, N, A, LDA, AFAC, LDA, E,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'ZHESV_RK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of ZDRVHE_RK
+*
+ END
--- /dev/null
+*> \brief \b ZDRVSY_RK
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+* RWORK, IWORK, NOUT )
+*
+* .. Scalar Arguments ..
+* LOGICAL TSTERR
+* INTEGER NMAX, NN, NOUT, NRHS
+* DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+* LOGICAL DOTYPE( * )
+* INTEGER IWORK( * ), NVAL( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( *),
+* $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZDRVSY_RK tests the driver routines ZSYSV_RK.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] DOTYPE
+*> \verbatim
+*> DOTYPE is LOGICAL array, dimension (NTYPES)
+*> The matrix types to be used for testing. Matrices of type j
+*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*> \endverbatim
+*>
+*> \param[in] NN
+*> \verbatim
+*> NN is INTEGER
+*> The number of values of N contained in the vector NVAL.
+*> \endverbatim
+*>
+*> \param[in] NVAL
+*> \verbatim
+*> NVAL is INTEGER array, dimension (NN)
+*> The values of the matrix dimension N.
+*> \endverbatim
+*>
+*> \param[in] NRHS
+*> \verbatim
+*> NRHS is INTEGER
+*> The number of right hand side vectors to be generated for
+*> each linear system.
+*> \endverbatim
+*>
+*> \param[in] THRESH
+*> \verbatim
+*> THRESH is DOUBLE PRECISION
+*> The threshold value for the test ratios. A result is
+*> included in the output file if RESULT >= THRESH. To have
+*> every test ratio printed, use THRESH = 0.
+*> \endverbatim
+*>
+*> \param[in] TSTERR
+*> \verbatim
+*> TSTERR is LOGICAL
+*> Flag that indicates whether error exits are to be tested.
+*> \endverbatim
+*>
+*> \param[in] NMAX
+*> \verbatim
+*> NMAX is INTEGER
+*> The maximum value permitted for N, used in dimensioning the
+*> work arrays.
+*> \endverbatim
+*>
+*> \param[out] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[out] AINV
+*> \verbatim
+*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
+*> \endverbatim
+*>
+*> \param[out] B
+*> \verbatim
+*> B is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] X
+*> \verbatim
+*> X is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] XACT
+*> \verbatim
+*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
+*> \endverbatim
+*>
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (NMAX)
+*> \endverbatim
+*>
+*> \param[in] NOUT
+*> \verbatim
+*> NOUT is INTEGER
+*> The unit number for output.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2013
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
+ $ RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2013
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NMAX, NN, NOUT, NRHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), NVAL( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 11, NTESTS = 3 )
+ INTEGER NFACT
+ PARAMETER ( NFACT = 2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ZEROT
+ CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
+ CHARACTER*3 MATPATH, PATH
+ INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
+ $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
+ $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
+ DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
+* ..
+* .. Local Arrays ..
+ CHARACTER FACTS( NFACT ), UPLOS( 2 )
+ INTEGER ISEED( 4 ), ISEEDY( 4 )
+ DOUBLE PRECISION RESULT( NTESTS )
+
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION ZLANSY
+ EXTERNAL ZLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04,
+ $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY,
+ $ ZSYSV_RK, ZSYT01_3, ZSYT02, ZSYTRF_RK, ZSYTRI_3
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*32 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 /
+ DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+* Test path
+*
+ PATH( 1: 1 ) = 'Zomplex precision'
+ PATH( 2: 3 ) = 'SK'
+*
+* Path to generate matrices
+*
+ MATPATH( 1: 1 ) = 'Zomplex precision'
+ MATPATH( 2: 3 ) = 'SY'
+*
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+ LWORK = MAX( 2*NMAX, NMAX*NRHS )
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL ZERRVX( PATH, NOUT )
+ INFOT = 0
+*
+* Set the block size and minimum block size for which the block
+* routine should be used, which will be later returned by ILAENV.
+*
+ NB = 1
+ NBMIN = 2
+ CALL XLAENV( 1, NB )
+ CALL XLAENV( 2, NBMIN )
+*
+* Do for each value of N in NVAL
+*
+ DO 180 IN = 1, NN
+ N = NVAL( IN )
+ LDA = MAX( N, 1 )
+ XTYPE = 'N'
+ NIMAT = NTYPES
+ IF( N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 170 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 170
+*
+* Skip types 3, 4, 5, or 6 if the matrix size is too small.
+*
+ ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
+ IF( ZEROT .AND. N.LT.IMAT-2 )
+ $ GO TO 170
+*
+* Do first for UPLO = 'U', then for UPLO = 'L'
+*
+ DO 160 IUPLO = 1, 2
+ UPLO = UPLOS( IUPLO )
+*
+ IF( IMAT.NE.NTYPES ) THEN
+*
+* Begin generate the test matrix A.
+*
+* Set up parameters with ZLATB4 for the matrix generator
+* based on the type of matrix to be generated.
+*
+ CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
+ $ MODE, CNDNUM, DIST )
+*
+* Generate a matrix with ZLATMS.
+*
+ SRNAMT = 'ZLATMS'
+ CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
+ $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
+ $ WORK, INFO )
+*
+* Check error code from DLATMS and handle error.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N,
+ $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
+ GO TO 160
+ END IF
+*
+* For types 3-6, zero one or more rows and columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.3 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.4 ) THEN
+ IZERO = N
+ ELSE
+ IZERO = N / 2 + 1
+ END IF
+*
+ IF( IMAT.LT.6 ) THEN
+*
+* Set row and column IZERO to zero.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ IOFF = ( IZERO-1 )*LDA
+ DO 20 I = 1, IZERO - 1
+ A( IOFF+I ) = ZERO
+ 20 CONTINUE
+ IOFF = IOFF + IZERO
+ DO 30 I = IZERO, N
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 30 CONTINUE
+ ELSE
+ IOFF = IZERO
+ DO 40 I = 1, IZERO - 1
+ A( IOFF ) = ZERO
+ IOFF = IOFF + LDA
+ 40 CONTINUE
+ IOFF = IOFF - IZERO
+ DO 50 I = IZERO, N
+ A( IOFF+I ) = ZERO
+ 50 CONTINUE
+ END IF
+ ELSE
+ IF( IUPLO.EQ.1 ) THEN
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 70 J = 1, N
+ I2 = MIN( J, IZERO )
+ DO 60 I = 1, I2
+ A( IOFF+I ) = ZERO
+ 60 CONTINUE
+ IOFF = IOFF + LDA
+ 70 CONTINUE
+ ELSE
+*
+* Set the first IZERO rows and columns to zero.
+*
+ IOFF = 0
+ DO 90 J = 1, N
+ I1 = MAX( J, IZERO )
+ DO 80 I = I1, N
+ A( IOFF+I ) = ZERO
+ 80 CONTINUE
+ IOFF = IOFF + LDA
+ 90 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IZERO = 0
+ END IF
+ ELSE
+*
+* IMAT = NTYPES: Use a special block diagonal matrix to
+* test alternate code for the 2-by-2 blocks.
+*
+ CALL ZLATSY( UPLO, N, A, LDA, ISEED )
+ END IF
+*
+ DO 150 IFACT = 1, NFACT
+*
+* Do first for FACT = 'F', then for other values.
+*
+ FACT = FACTS( IFACT )
+*
+* Compute the condition number for comparison with
+* the value returned by ZSYSVX_ROOK.
+*
+ IF( ZEROT ) THEN
+ IF( IFACT.EQ.1 )
+ $ GO TO 150
+ RCONDC = ZERO
+*
+ ELSE IF( IFACT.EQ.1 ) THEN
+*
+* Compute the 1-norm of A.
+*
+ ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* Factor the matrix A.
+*
+
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV,
+ $ LWORK, INFO )
+*
+* Compute inv(A) and take its norm.
+*
+ CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
+ LWORK = (N+NB+1)*(NB+3)
+*
+* We need to copute the invesrse to compute
+* RCONDC that is used later in TEST3.
+*
+ CALL ZSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
+ $ WORK, LWORK, INFO )
+ AINVNM = ZLANSY( '1', UPLO, N, AINV, LDA, RWORK )
+*
+* Compute the 1-norm condition number of A.
+*
+ IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDC = ONE
+ ELSE
+ RCONDC = ( ONE / ANORM ) / AINVNM
+ END IF
+ END IF
+*
+* Form an exact solution and set the right hand side.
+*
+ SRNAMT = 'ZLARHS'
+ CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
+ $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+*
+* --- Test ZSYSV_RK ---
+*
+ IF( IFACT.EQ.2 ) THEN
+ CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
+*
+* Factor the matrix and solve the system using
+* ZSYSV_RK.
+*
+ SRNAMT = 'ZSYSV_RK'
+ CALL ZSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
+ $ X, LDA, WORK, LWORK, INFO )
+*
+* Adjust the expected value of INFO to account for
+* pivoting.
+*
+ K = IZERO
+ IF( K.GT.0 ) THEN
+ 100 CONTINUE
+ IF( IWORK( K ).LT.0 ) THEN
+ IF( IWORK( K ).NE.-K ) THEN
+ K = -IWORK( K )
+ GO TO 100
+ END IF
+ ELSE IF( IWORK( K ).NE.K ) THEN
+ K = IWORK( K )
+ GO TO 100
+ END IF
+ END IF
+*
+* Check error code from ZSYSV_RK and handle error.
+*
+ IF( INFO.NE.K ) THEN
+ CALL ALAERH( PATH, 'ZSYSV_RK', INFO, K, UPLO,
+ $ N, N, -1, -1, NRHS, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ ELSE IF( INFO.NE.0 ) THEN
+ GO TO 120
+ END IF
+*
+*+ TEST 1 Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL ZSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E,
+ $ IWORK, AINV, LDA, RWORK,
+ $ RESULT( 1 ) )
+*
+*+ TEST 2 Compute residual of the computed solution.
+*
+ CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
+ CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
+ $ LDA, RWORK, RESULT( 2 ) )
+*
+*+ TEST 3
+* Check solution from generated exact solution.
+*
+ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
+ $ RESULT( 3 ) )
+ NT = 3
+*
+* Print information about the tests that did not pass
+* the threshold.
+*
+ DO 110 K = 1, NT
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALADHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )'ZSYSV_RK', UPLO,
+ $ N, IMAT, K, RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 110 CONTINUE
+ NRUN = NRUN + NT
+ 120 CONTINUE
+ END IF
+*
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
+ $ ', test ', I2, ', ratio =', G12.5 )
+ RETURN
+*
+* End of ZDRVSY_RK
+*
+ END
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IP( NMAX )
DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX )
COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS,
- $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK,
- $ ZHETRF_AA, ZHETRI, ZHETRI_ROOK, ZHETRI2,
- $ ZHETRS, ZHETRS_ROOK, ZHETRS_AA, ZHPCON, ZHPRFS,
- $ ZHPTRF, ZHPTRI, ZHPTRS
+ EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_3, ZHECON_ROOK,
+ $ ZHERFS, ZHETF2, ZHETF2_RK, ZHETF2_ROOK, ZHETRF,
+ $ ZHETRF_RK, ZHETRF_ROOK, ZHETRF_AA, ZHETRI,
+ $ ZHETRI_3, ZHETRI_3X, ZHETRI_ROOK, ZHETRI2,
+ $ ZHETRI2X, ZHETRS, ZHETRS_3, ZHETRS_ROOK,
+ $ ZHETRS_AA, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, ZHPTRS
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ -1.D0 / DBLE( I+J ) )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
20 CONTINUE
ANRM = 1.0D0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'HE' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* ZHETRF
*
SRNAMT = 'ZHETRF'
INFOT = 4
CALL ZHETRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK )
*
* ZHETF2
*
CALL ZHETRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'ZHETRI2', INFOT, NOUT, LERR, OK )
*
+* ZHETRI2X
+*
+ SRNAMT = 'ZHETRI2X'
+ INFOT = 1
+ CALL ZHETRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK )
+*
* ZHETRS
*
SRNAMT = 'ZHETRS'
INFOT = 6
CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with "rook"
+* of a Hermitian indefinite matrix with rook
* (bounded Bunch-Kaufman) diagonal pivoting method.
-*
- ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* ZHETRF_ROOK
*
INFOT = 4
CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
*
* ZHETF2_ROOK
*
INFOT = 6
CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
+*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* ZHETRF_RK
+*
+ SRNAMT = 'ZHETRF_RK'
+ INFOT = 1
+ CALL ZHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+*
+* ZHETF2_RK
+*
+ SRNAMT = 'ZHETF2_RK'
+ INFOT = 1
+ CALL ZHETF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK )
+*
+* ZHETRI_3
+*
+ SRNAMT = 'ZHETRI_3'
+ INFOT = 1
+ CALL ZHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+*
+* ZHETRI_3X
+*
+ SRNAMT = 'ZHETRI_3X'
+ INFOT = 1
+ CALL ZHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK )
+*
+* ZHETRS_3
+*
+ SRNAMT = 'ZHETRS_3'
+ INFOT = 1
+ CALL ZHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+*
+* ZHECON_3
+*
+ SRNAMT = 'ZHECON_3'
+ INFOT = 1
+ CALL ZHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHECON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO)
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
*
* Test error exits of the routines that use factorization
* of a Hermitian indefinite matrix with Aasen's algorithm.
INFOT = 8
CALL ZHETRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
* Test error exits of the routines that use factorization
* of a Hermitian indefinite packed matrix with patrial
* (Bunch-Kaufman) diagonal pivoting method.
-*
- ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
* ZHPTRF
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRHE( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
$ S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
EXTERNAL LSAMEN
* ..
* .. External Subroutines ..
- EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS,
- $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK,
- $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS,
- $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI,
- $ ZHPTRS, ZHERFSX
+ EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_3, ZHECON_ROOK,
+ $ ZHERFS, ZHETF2, ZHETF2_RK, ZHETF2_ROOK, ZHETRF,
+ $ ZHETRF_RK, ZHETRF_ROOK, ZHETRI, ZHETRI_3,
+ $ ZHETRI_3X, ZHETRI_ROOK, ZHETRI2, ZHETRI2X,
+ $ ZHETRS, ZHETRS_3, ZHETRS_ROOK, ZHPCON,
+ $ ZHPRFS, ZHPTRF, ZHPTRI, ZHPTRS, ZHERFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ -1.D0 / DBLE( I+J ) )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
INFOT = 4
CALL ZHETRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK )
*
* ZHETF2
*
CALL ZHETRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'ZHETRI2', INFOT, NOUT, LERR, OK )
*
+* ZHETRI2X
+*
+ SRNAMT = 'ZHETRI2X'
+ INFOT = 1
+ CALL ZHETRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK )
+*
* ZHETRS
*
SRNAMT = 'ZHETRS'
INFOT = 6
CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a Hermitian indefinite matrix with "rook"
+* of a Hermitian indefinite matrix with rook
* (bounded Bunch-Kaufman) diagonal pivoting method.
-*
- ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* ZHETRF_ROOK
*
INFOT = 4
CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK )
*
* ZHETF2_ROOK
*
INFOT = 6
CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a Hermitian indefinite packed matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* ZHETRF_RK
+*
+ SRNAMT = 'ZHETRF_RK'
+ INFOT = 1
+ CALL ZHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK )
+*
+* ZHETF2_RK
+*
+ SRNAMT = 'ZHETF2_RK'
+ INFOT = 1
+ CALL ZHETF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK )
+*
+* ZHETRI_3
+*
+ SRNAMT = 'ZHETRI_3'
+ INFOT = 1
+ CALL ZHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK )
+*
+* ZHETRI_3X
+*
+ SRNAMT = 'ZHETRI_3X'
+ INFOT = 1
+ CALL ZHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK )
+*
+* ZHETRS_3
+*
+ SRNAMT = 'ZHETRS_3'
+ INFOT = 1
+ CALL ZHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK )
+*
+* ZHECON_3
+*
+ SRNAMT = 'ZHECON_3'
+ INFOT = 1
+ CALL ZHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZHECON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO)
+ CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a Hermitian indefinite packed matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* ZHPTRF
*
SRNAMT = 'ZHPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER IP( NMAX )
DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX )
COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI,
- $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2,
- $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI,
- $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK
+ $ ZSPTRS, ZSYCON, ZSYCON_3, ZSYCON_ROOK, ZSYRFS,
+ $ ZSYTF2, ZSYTF2_RK, ZSYTF2_ROOK, ZSYTRF,
+ $ ZSYTRF_RK, ZSYTRF_ROOK, ZSYTRI, ZSYTRI_3,
+ $ ZSYTRI_3X, ZSYTRI_ROOK, ZSYTRI2, ZSYTRI2Z,
+ $ ZSYTRS, ZSYTRS_3, ZSYTRS_ROOK
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ -1.D0 / DBLE( I+J ) )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
20 CONTINUE
ANRM = 1.0D0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* ZSYTRF
*
SRNAMT = 'ZSYTRF'
INFOT = 4
CALL ZSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK )
*
* ZSYTF2
*
CALL ZSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'ZSYTRI2', INFOT, NOUT, LERR, OK )
*
+* ZSYTRI2X
+*
+ SRNAMT = 'ZSYTRI2X'
+ INFOT = 1
+ CALL ZSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* ZSYTRS
*
SRNAMT = 'ZSYTRS'
INFOT = 6
CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK )
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with "rook"
-* (bounded Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
* ZSYTRF_ROOK
*
SRNAMT = 'ZSYTRF_ROOK'
INFOT = 4
CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* ZSYTF2_ROOK
*
INFOT = 6
CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) pivoting.
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* ZSYTRF_RK
+*
+ SRNAMT = 'ZSYTRF_RK'
+ INFOT = 1
+ CALL ZSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTF2_RK
+*
+ SRNAMT = 'ZSYTF2_RK'
+ INFOT = 1
+ CALL ZSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRI_3
+*
+ SRNAMT = 'ZSYTRI_3'
+ INFOT = 1
+ CALL ZSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRI_3X
+*
+ SRNAMT = 'ZSYTRI_3X'
+ INFOT = 1
+ CALL ZSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRS_3
+*
+ SRNAMT = 'ZSYTRS_3'
+ INFOT = 1
+ CALL ZSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* ZSYCON_3
+*
+ SRNAMT = 'ZSYCON_3'
+ INFOT = 1
+ CALL ZSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO)
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
+*
* ZSPTRF
*
SRNAMT = 'ZSPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRSY( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
$ S( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI,
- $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2,
- $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI,
- $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK,
- $ ZSYRFSX
+ $ ZSPTRS, ZSYCON, ZSYCON_3, ZSYCON_ROOK, ZSYRFS,
+ $ ZSYTF2, ZSYTF2_RK, ZSYTF2_ROOK, ZSYTRF,
+ $ ZSYTRF_RK, ZSYTRF_ROOK, ZSYTRI, ZSYTRI_3,
+ $ ZSYTRI_3X, ZSYTRI_ROOK, ZSYTRI2, ZSYTRI2X,
+ $ ZSYTRS, ZSYTRS_3, ZSYTRS_ROOK, ZSYRFSX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ -1.D0 / DBLE( I+J ) )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
20 CONTINUE
ANRM = 1.0D0
OK = .TRUE.
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with patrial
-* (Bunch-Kaufman) diagonal pivoting method.
*
IF( LSAMEN( 2, C2, 'SY' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with patrial
+* (Bunch-Kaufman) diagonal pivoting method.
+*
* ZSYTRF
*
SRNAMT = 'ZSYTRF'
INFOT = 4
CALL ZSYTRF( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK )
*
* ZSYTF2
*
CALL ZSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO )
CALL CHKXER( 'ZSYTRI2', INFOT, NOUT, LERR, OK )
*
+* ZSYTRI2X
+*
+ SRNAMT = 'ZSYTRI2X'
+ INFOT = 1
+ CALL ZSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK )
+*
* ZSYTRS
*
SRNAMT = 'ZSYTRS'
INFOT = 6
CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK )
-*
-* Test error exits of the routines that use factorization
-* of a symmetric indefinite matrix with "rook"
-* (bounded Bunch-Kaufman) diagonal pivoting method.
*
ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) diagonal pivoting method.
+*
* ZSYTRF_ROOK
*
SRNAMT = 'ZSYTRF_ROOK'
INFOT = 4
CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO )
CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK )
*
* ZSYTF2_ROOK
*
INFOT = 6
CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO )
CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
*
* Test error exits of the routines that use factorization
-* of a symmetric indefinite packed matrix with patrial
-* (Bunch-Kaufman) pivoting.
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+* ZSYTRF_RK
+*
+ SRNAMT = 'ZSYTRF_RK'
+ INFOT = 1
+ CALL ZSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTF2_RK
+*
+ SRNAMT = 'ZSYTF2_RK'
+ INFOT = 1
+ CALL ZSYTF2_RK( '/', 0, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTF2_RK( 'U', -1, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTF2_RK( 'U', 2, A, 1, E, IP, INFO )
+ CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRI_3
+*
+ SRNAMT = 'ZSYTRI_3'
+ INFOT = 1
+ CALL ZSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO )
+ CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRI_3X
+*
+ SRNAMT = 'ZSYTRI_3X'
+ INFOT = 1
+ CALL ZSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO )
+ CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK )
+*
+* ZSYTRS_3
+*
+ SRNAMT = 'ZSYTRS_3'
+ INFOT = 1
+ CALL ZSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO )
+ CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK )
+*
+* ZSYCON_3
+*
+ SRNAMT = 'ZSYCON_3'
+ INFOT = 1
+ CALL ZSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL ZSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO )
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL ZSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO)
+ CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
+* Test error exits of the routines that use factorization
+* of a symmetric indefinite packed matrix with patrial
+* (Bunch-Kaufman) pivoting.
+*
* ZSPTRF
*
SRNAMT = 'ZSPTRF'
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2013
+*> \date November 2016
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.5.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2013
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
DOUBLE PRECISION C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
$ RF( NMAX ), RW( NMAX )
COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV,
- $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV,
- $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV,
- $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV,
- $ ZSYSV_AA, ZSYSV_ROOK, ZSYSVX
+ $ ZGTSVX, ZHESV, ZHESV_RK, ZHESV_ROOK, ZHESVX,
+ $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX,
+ $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX,
+ $ ZSYSV, ZSYSV_AA, ZSYSV_RK, ZSYSV_ROOK,
+ $ ZSYSVX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ -1.D0 / DBLE( I+J ) )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
INFOT = 8
CALL ZHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK )
*
* ZHESVX
*
$ RCOND, R1, R2, W, 3, RW, INFO )
CALL CHKXER( 'ZHESVX', INFOT, NOUT, LERR, OK )
*
- ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
-*
-* ZHESV_AA
-*
- SRNAMT = 'ZHESV_AA'
- INFOT = 1
- CALL ZHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 2
- CALL ZHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 3
- CALL ZHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
- INFOT = 8
- CALL ZHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
- CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
-*
-
ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN
*
* ZHESV_ROOK
INFOT = 8
CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
+*
+* ZSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a Hermitian indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'ZHESV_RK'
+ INFOT = 1
+ CALL ZHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN
+*
+* ZHESV_AA
+*
+ SRNAMT = 'ZHESV_AA'
+ INFOT = 1
+ CALL ZHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL ZHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
INFOT = 8
CALL ZSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK )
*
* ZSYSVX
*
INFOT = 8
CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* ZSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'ZSYSV_RK'
+ INFOT = 1
+ CALL ZSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
-*> \date November 2015
+*> \date November 2016
*
*> \ingroup complex16_lin
*
* =====================================================================
SUBROUTINE ZERRVX( PATH, NUNIT )
*
-* -- LAPACK test routine (version 3.6.0) --
+* -- LAPACK test routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* November 2015
+* November 2016
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
$ RF( NMAX ), RW( NMAX ), ERR_BNDS_N( NMAX, 3 ),
$ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 )
COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
- $ W( 2*NMAX ), X( NMAX )
+ $ E( NMAX ), W( 2*NMAX ), X( NMAX )
* ..
* .. External Functions ..
LOGICAL LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV,
- $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV,
- $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV,
- $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV,
- $ ZSYSV_ROOK, ZSYSVX, ZGESVXX, ZSYSVXX, ZPOSVXX,
- $ ZHESVXX, ZGBSVXX
+ $ ZGTSVX, ZHESV, ZHESV_RK, ZHESV_ROOK, ZHESVX,
+ $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX,
+ $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX,
+ $ ZSYSV, ZSYSV_RK, ZSYSV_ROOK, ZSYSVX, ZGESVXX,
+ $ ZSYSVXX, ZPOSVXX, ZHESVXX, ZGBSVXX
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
$ -1.D0 / DBLE( I+J ) )
10 CONTINUE
B( J ) = 0.D0
+ E( J ) = 0.D0
R1( J ) = 0.D0
R2( J ) = 0.D0
W( J ) = 0.D0
INFOT = 8
CALL ZHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK )
*
* ZHESVX
*
INFOT = 8
CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK )
+*
+ ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN
+*
+* ZSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a Hermitian indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'ZHESV_RK'
+ INFOT = 1
+ CALL ZHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN
*
INFOT = 8
CALL ZSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK )
*
* ZSYSVX
*
INFOT = 8
CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO )
CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO )
+*
+ ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN
+*
+* ZSYSV_RK
+*
+* Test error exits of the driver that uses factorization
+* of a symmetric indefinite matrix with rook
+* (bounded Bunch-Kaufman) pivoting with the new storage
+* format for factors L ( or U) and D.
+*
+* L (or U) is stored in A, diagonal of D is stored on the
+* diagonal of A, subdiagonal of D is stored in a separate array E.
+*
+ SRNAMT = 'ZSYSV_RK'
+ INFOT = 1
+ CALL ZSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL ZSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL ZSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL ZSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL ZSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO )
+ CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK )
*
ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
*
--- /dev/null
+*> \brief \b ZHET01_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+* LDC, RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZHET01_3 reconstructs a Hermitian indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization computed by ZHETRF_RK
+*> (or ZHETRF_BK) and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> Hermitian matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The original Hermitian matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by ZHETRF_RK and ZHETRF_BK:
+*> a) ONLY diagonal elements of the Hermitian block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC.
+*> LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the Hermitian block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from ZHETRF_RK (or ZHETRF_BK).
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ E( * )
+* ..
+*
+* =====================================================================
+*
+* .. 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, INFO, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION ZLANHE, DLAMCH
+ EXTERNAL LSAME, ZLANHE, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLASET, ZLAVHE_ROOK, ZSYCONVF_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DIMAG, DBLE
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* a) Revert to multiplyers of L
+*
+ CALL ZSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+* 1) Determine EPS and the norm of A.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK )
+*
+* Check the imaginary parts of the diagonal elements and return with
+* an error code if any are nonzero.
+*
+ DO J = 1, N
+ IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN
+ RESID = ONE / EPS
+ RETURN
+ END IF
+ END DO
+*
+* 2) Initialize C to the identity matrix.
+*
+ CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* 3) Call ZLAVHE_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL ZLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 4) Call ZLAVHE_RK again to multiply by U (or L ).
+*
+ CALL ZLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 5) Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO J = 1, N
+ DO I = 1, J - 1
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ C( J, J ) = C( J, J ) - DBLE( A( J, J ) )
+ END DO
+ ELSE
+ DO J = 1, N
+ C( J, J ) = C( J, J ) - DBLE( A( J, J ) )
+ DO I = J + 1, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ END IF
+*
+* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = ZLANHE( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID/DBLE( N ) )/ANORM ) / EPS
+ END IF
+*
+* b) Convert to factor of L (or U)
+*
+ CALL ZSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+ RETURN
+*
+* End of ZHET01_3
+*
+ END
--- /dev/null
+*> \brief \b ZSYT01_3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+* LDC, RWORK, RESID )
+*
+* .. Scalar Arguments ..
+* CHARACTER UPLO
+* INTEGER LDA, LDAFAC, LDC, N
+* DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+* INTEGER IPIV( * )
+* DOUBLE PRECISION RWORK( * )
+* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+* E( * )
+* ..
+*
+*
+*> \par Purpose:
+* =============
+*>
+*> \verbatim
+*>
+*> ZSYT01_3 reconstructs a symmetric indefinite matrix A from its
+*> block L*D*L' or U*D*U' factorization computed by ZSYTRF_RK
+*> (or ZSYTRF_BK) and computes the residual
+*> norm( C - A ) / ( N * norm(A) * EPS ),
+*> where C is the reconstructed matrix and EPS is the machine epsilon.
+*> \endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] UPLO
+*> \verbatim
+*> UPLO is CHARACTER*1
+*> Specifies whether the upper or lower triangular part of the
+*> symmetric matrix A is stored:
+*> = 'U': Upper triangular
+*> = 'L': Lower triangular
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of rows and columns of the matrix A. N >= 0.
+*> \endverbatim
+*>
+*> \param[in] A
+*> \verbatim
+*> A is COMPLEX*16 array, dimension (LDA,N)
+*> The original symmetric matrix A.
+*> \endverbatim
+*>
+*> \param[in] LDA
+*> \verbatim
+*> LDA is INTEGER
+*> The leading dimension of the array A. LDA >= max(1,N)
+*> \endverbatim
+*>
+*> \param[in] AFAC
+*> \verbatim
+*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
+*> Diagonal of the block diagonal matrix D and factors U or L
+*> as computed by ZSYTRF_RK and ZSYTRF_BK:
+*> a) ONLY diagonal elements of the symmetric block diagonal
+*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
+*> (superdiagonal (or subdiagonal) elements of D
+*> should be provided on entry in array E), and
+*> b) If UPLO = 'U': factor U in the superdiagonal part of A.
+*> If UPLO = 'L': factor L in the subdiagonal part of A.
+*> \endverbatim
+*>
+*> \param[in] LDAFAC
+*> \verbatim
+*> LDAFAC is INTEGER
+*> The leading dimension of the array AFAC.
+*> LDAFAC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[in] E
+*> \verbatim
+*> E is COMPLEX*16 array, dimension (N)
+*> On entry, contains the superdiagonal (or subdiagonal)
+*> elements of the symmetric block diagonal matrix D
+*> with 1-by-1 or 2-by-2 diagonal blocks, where
+*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced;
+*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
+*> \endverbatim
+*>
+*> \param[in] IPIV
+*> \verbatim
+*> IPIV is INTEGER array, dimension (N)
+*> The pivot indices from ZSYTRF_RK (or ZSYTRF_BK).
+*> \endverbatim
+*>
+*> \param[out] C
+*> \verbatim
+*> C is COMPLEX*16 array, dimension (LDC,N)
+*> \endverbatim
+*>
+*> \param[in] LDC
+*> \verbatim
+*> LDC is INTEGER
+*> The leading dimension of the array C. LDC >= max(1,N).
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (N)
+*> \endverbatim
+*>
+*> \param[out] RESID
+*> \verbatim
+*> RESID is DOUBLE PRECISION
+*> If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
+*> If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date November 2016
+*
+*> \ingroup complex16_lin
+*
+* =====================================================================
+ SUBROUTINE ZSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C,
+ $ LDC, RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.7.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* November 2016
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDAFAC, LDC, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION RWORK( * )
+ COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
+ $ E( * )
+* ..
+*
+* =====================================================================
+*
+* .. 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, INFO, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, ZLANSY
+ EXTERNAL LSAME, DLAMCH, ZLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLASET, ZLAVSY_ROOK, ZSYCONVF_ROOK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if N = 0.
+*
+ IF( N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* a) Revert to multiplyers of L
+*
+ CALL ZSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+* 1) Determine EPS and the norm of A.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK )
+*
+* 2) Initialize C to the identity matrix.
+*
+ CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC )
+*
+* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ).
+*
+ CALL ZLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 4) Call ZLAVSY_ROOK again to multiply by U (or L ).
+*
+ CALL ZLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC,
+ $ LDAFAC, IPIV, C, LDC, INFO )
+*
+* 5) Compute the difference C - A .
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO J = 1, N
+ DO I = 1, J
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ ELSE
+ DO J = 1, N
+ DO I = J, N
+ C( I, J ) = C( I, J ) - A( I, J )
+ END DO
+ END DO
+ END IF
+*
+* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
+*
+ RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
+ END IF
+
+*
+* b) Convert to factor of L (or U)
+*
+ CALL ZSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO )
+*
+ RETURN
+*
+* End of ZSYT01_3
+*
+ END
CPT 12 List types on next line if 0 < NTYPES < 12
CHE 10 List types on next line if 0 < NTYPES < 10
CHR 10 List types on next line if 0 < NTYPES < 10
+CHK 10 List types on next line if 0 < NTYPES < 10
CHA 10 List types on next line if 0 < NTYPES < 10
CHP 10 List types on next line if 0 < NTYPES < 10
CSY 11 List types on next line if 0 < NTYPES < 11
CSR 11 List types on next line if 0 < NTYPES < 11
+CSK 11 List types on next line if 0 < NTYPES < 11
CSP 11 List types on next line if 0 < NTYPES < 11
CTR 18 List types on next line if 0 < NTYPES < 18
CTP 18 List types on next line if 0 < NTYPES < 18
DPP 9 List types on next line if 0 < NTYPES < 9
DPB 8 List types on next line if 0 < NTYPES < 8
DPT 12 List types on next line if 0 < NTYPES < 12
-DSA 10 List types on next line if 0 < NTYPES < 10
DSY 10 List types on next line if 0 < NTYPES < 10
DSR 10 List types on next line if 0 < NTYPES < 10
+DSK 10 List types on next line if 0 < NTYPES < 10
+DSA 10 List types on next line if 0 < NTYPES < 10
DSP 10 List types on next line if 0 < NTYPES < 10
DTR 18 List types on next line if 0 < NTYPES < 18
DTP 18 List types on next line if 0 < NTYPES < 18
SPP 9 List types on next line if 0 < NTYPES < 9
SPB 8 List types on next line if 0 < NTYPES < 8
SPT 12 List types on next line if 0 < NTYPES < 12
-SSA 10 List types on next line if 0 < NTYPES < 10
SSY 10 List types on next line if 0 < NTYPES < 10
SSR 10 List types on next line if 0 < NTYPES < 10
+SSK 10 List types on next line if 0 < NTYPES < 10
+SSA 10 List types on next line if 0 < NTYPES < 10
SSP 10 List types on next line if 0 < NTYPES < 10
STR 18 List types on next line if 0 < NTYPES < 18
STP 18 List types on next line if 0 < NTYPES < 18
ZPP 9 List types on next line if 0 < NTYPES < 9
ZPB 8 List types on next line if 0 < NTYPES < 8
ZPT 12 List types on next line if 0 < NTYPES < 12
-ZHA 10 List types on next line if 0 < NTYPES < 10
ZHE 10 List types on next line if 0 < NTYPES < 10
ZHR 10 List types on next line if 0 < NTYPES < 10
+ZHK 10 List types on next line if 0 < NTYPES < 10
+ZHA 10 List types on next line if 0 < NTYPES < 10
ZHP 10 List types on next line if 0 < NTYPES < 10
ZSY 11 List types on next line if 0 < NTYPES < 11
ZSR 11 List types on next line if 0 < NTYPES < 11
+ZSK 11 List types on next line if 0 < NTYPES < 11
ZSP 11 List types on next line if 0 < NTYPES < 11
ZTR 18 List types on next line if 0 < NTYPES < 18
ZTP 18 List types on next line if 0 < NTYPES < 18
projects / platform / upstream / lapack.git / commitdiff